From brasspen at gmail.com Mon Jun 1 13:54:43 2015 From: brasspen at gmail.com (Chris Cunnington) Date: Mon Jun 1 13:54:49 2015 Subject: [squeak-dev] Cuis/GreenNeon blog post Message-ID: <5832F289-C9D0-4F02-A229-F2516C8FFF13@gmail.com> A blog post about Cuis, WebClient and GreenNeon. https://websela.wordpress.com/ Chris -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150601/cc9f561e/attachment.htm From stephan at stack.nl Mon Jun 1 14:20:20 2015 From: stephan at stack.nl (Stephan Eggermont) Date: Mon Jun 1 14:20:39 2015 Subject: [squeak-dev] Pier/Pillar CI build? Message-ID: What would be needed to create a squeak CI build for Pier/Pillar? The changes made in the Pharo version sometimes break other versions and it would be nice to notice before someone tries loading. Stephan From karlramberg at gmail.com Mon Jun 1 18:05:54 2015 From: karlramberg at gmail.com (karl ramberg) Date: Mon Jun 1 18:05:57 2015 Subject: [squeak-dev] XMLTokenizer problem with ampersand Message-ID: Hi, I'm parsing some html docs but the XMLTokenizer chockes on a '&' followed by a space in a string. I guess '&' is used for other stuff than a 'and' in html and it causes error when used in plain text. Does anybody have fix for this? Karl -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150601/b2649bc4/attachment.htm From asqueaker at gmail.com Mon Jun 1 18:41:24 2015 From: asqueaker at gmail.com (Chris Muller) Date: Mon Jun 1 18:41:28 2015 Subject: [squeak-dev] Bug: list filtering is acting on multiple lists at once Message-ID: 1) Standard TrunkImage, default preference settings. 2) Open a browser, select a class. 3) Select a method category. 4) Move mouse into methods list, but don't click. 5) Type a filter. Both the category list (which has keyboard focus) AND the list under the hand filtering simultaneously. From karlramberg at gmail.com Mon Jun 1 20:11:23 2015 From: karlramberg at gmail.com (karl ramberg) Date: Mon Jun 1 20:11:27 2015 Subject: [squeak-dev] BUG Automagic scrolling ? Message-ID: In latest image the mouse seem to scroll sliders just by mouse over the scroll bar. It's a very unusual behavior, and I think I would like to opt out of it. Is there a preference or is this a bug ? Karl -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150601/6b8cdc53/attachment.htm From karlramberg at gmail.com Mon Jun 1 20:20:36 2015 From: karlramberg at gmail.com (karl ramberg) Date: Mon Jun 1 20:20:40 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: References: Message-ID: The scrolling bug is caused by this change: http://source.squeak.org/trunk/Morphic-cmm.984.mcz Morph>>handlesMouseMove: anEvent "Do I want to receive mouseMove: when the hand passes over the receiver? 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." ---> self eventHandler ifNotNil: [^ self eventHandler handlesMouseMove: anEvent]. <------- anEvent hand hasSubmorphs ifTrue: [ ^ false ]. (anEvent anyButtonPressed and: [ anEvent hand mouseFocus == self ]) ifFalse: [ ^ false ]. ^ true There seem to be some unintended behavior because of this change. Karl On Mon, Jun 1, 2015 at 10:11 PM, karl ramberg wrote: > In latest image the mouse seem to scroll sliders just by mouse over the > scroll bar. > It's a very unusual behavior, and I think I would like to opt out of it. > > Is there a preference or is this a bug ? > > Karl > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150601/d942fe4f/attachment.htm From asqueaker at gmail.com Mon Jun 1 20:51:18 2015 From: asqueaker at gmail.com (Chris Muller) Date: Mon Jun 1 20:51:24 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: References: Message-ID: I can't recreate the problem. What browser are you using? The change you mention is consistent with every other type of event handling. It may have exposed another bug somewhere else, but I don't think it should be considered a bug, itself. On Mon, Jun 1, 2015 at 3:20 PM, karl ramberg wrote: > The scrolling bug is caused by this change: > > http://source.squeak.org/trunk/Morphic-cmm.984.mcz > > Morph>>handlesMouseMove: anEvent > "Do I want to receive mouseMove: when the hand passes over the receiver? > 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." > ---> self eventHandler ifNotNil: [^ self eventHandler handlesMouseMove: > anEvent]. <------- > anEvent hand hasSubmorphs ifTrue: [ ^ false ]. > (anEvent anyButtonPressed and: [ anEvent hand mouseFocus == self ]) ifFalse: > [ ^ false ]. > ^ true > > There seem to be some unintended behavior because of this change. > > Karl > > On Mon, Jun 1, 2015 at 10:11 PM, karl ramberg wrote: >> >> In latest image the mouse seem to scroll sliders just by mouse over the >> scroll bar. >> It's a very unusual behavior, and I think I would like to opt out of it. >> >> Is there a preference or is this a bug ? >> >> Karl > > > > > From eliot.miranda at gmail.com Mon Jun 1 20:53:30 2015 From: eliot.miranda at gmail.com (Eliot Miranda) Date: Mon Jun 1 20:53:34 2015 Subject: [squeak-dev] New Cog VMs available Message-ID: ... at http://www.mirandabanda.org/files/Cog/VM/VM.r3364 CogVM binaries as per VMMaker.oscog-eem.1331/r3364 General: Merge with Pharo (with VMMaker.oscog-EstebanLorenzano.1322). Changes are null to Squeak VM. Pulled in are conditionally compiled changes for directory & file creation (added ceration permissions) and to macro used to read image file (for iPhone). Cogit: Test the outerContext and method for sanity in the machine code closure value primitive(s). Spur must check to fail in the presence of forwarders. To support the primitive provide TstCqR support on x86 (already exists on ARM), and use it to implement genJumpImmediate: et al. Use the new genJumpImmediate: et al in various basic access primitives. Good for a 5%-10% increase in 0 tinyBenchmarks on Spur. Guard access to the inline cache tag in PICs in GC routines by inlineCacheTagsMayBeObjects. Spur: Spur must follow forwarders in machine code before it follows forwarders in stack pages (since stack page parsing examines methods). Further, closed PICs that refer to unmarked objects must be discarded in freeUnmarkedMachineCode. And closedPICRefersToUnmarkedObject: should guard against an immediate selector. -- best, Eliot -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150601/80344058/attachment.htm From jakob.reschke at student.hpi.de Mon Jun 1 21:01:20 2015 From: jakob.reschke at student.hpi.de (Jakob Reschke) Date: Mon Jun 1 21:01:44 2015 Subject: [squeak-dev] XMLTokenizer problem with ampersand In-Reply-To: References: Message-ID: I guess this will not help you, but a standalone ampersand is not valid XML (it is the leader for entities, if you want to have a literal ampersand in the text, the markup must be &), hence I would not expect any XML tokenizer or parser implementation to accept it. HTML is more relaxed about this, so a standalone amapersand is valid, but you would need some kind of HTMLTokenizer and I do not know whether there is such thing for Squeak. Anyone else knows one? Best regards Jakob 2015-06-01 20:05 GMT+02:00 karl ramberg : > Hi, > I'm parsing some html docs but the XMLTokenizer chockes on a '&' followed by > a space in a string. > I guess '&' is used for other stuff than a 'and' in html and it causes error > when used in plain text. > > Does anybody have fix for this? > > Karl From karlramberg at gmail.com Mon Jun 1 22:15:22 2015 From: karlramberg at gmail.com (karl ramberg) Date: Mon Jun 1 22:15:26 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: References: Message-ID: Hi, All windows with scroll panes are affected, AFAICT. I'm on Spur, but I doubt that has any significance. When I move the mouse over a scroll bar it scrolls without clicking on it. (Alas sometimes it stops auto-scrolling, without any clue why) Is quite disorienting, stuff scrolls out of view as I move the mouse in and out of panes. If this intended behavior, it must/should be made a preference. Karl On Mon, Jun 1, 2015 at 10:51 PM, Chris Muller wrote: > I can't recreate the problem. What browser are you using? > > The change you mention is consistent with every other type of event > handling. It may have exposed another bug somewhere else, but I don't > think it should be considered a bug, itself. > > On Mon, Jun 1, 2015 at 3:20 PM, karl ramberg > wrote: > > The scrolling bug is caused by this change: > > > > http://source.squeak.org/trunk/Morphic-cmm.984.mcz > > > > Morph>>handlesMouseMove: anEvent > > "Do I want to receive mouseMove: when the hand passes over the receiver? > > 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." > > ---> self eventHandler ifNotNil: [^ self eventHandler handlesMouseMove: > > anEvent]. <------- > > anEvent hand hasSubmorphs ifTrue: [ ^ false ]. > > (anEvent anyButtonPressed and: [ anEvent hand mouseFocus == self ]) > ifFalse: > > [ ^ false ]. > > ^ true > > > > There seem to be some unintended behavior because of this change. > > > > Karl > > > > On Mon, Jun 1, 2015 at 10:11 PM, karl ramberg > wrote: > >> > >> In latest image the mouse seem to scroll sliders just by mouse over the > >> scroll bar. > >> It's a very unusual behavior, and I think I would like to opt out of it. > >> > >> Is there a preference or is this a bug ? > >> > >> Karl > > > > > > > > > > > > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150602/c4cb1986/attachment.htm From karlramberg at gmail.com Mon Jun 1 22:20:49 2015 From: karlramberg at gmail.com (karl ramberg) Date: Mon Jun 1 22:20:52 2015 Subject: [squeak-dev] XMLTokenizer problem with ampersand In-Reply-To: References: Message-ID: Hi, thanks for the info. I guess I need a HTMLTokenizer for what I'm doing. I had issues with   as well, with the current XMLTokenizer Karl On Mon, Jun 1, 2015 at 11:01 PM, Jakob Reschke wrote: > I guess this will not help you, but a standalone ampersand is not > valid XML (it is the leader for entities, if you want to have a > literal ampersand in the text, the markup must be &), hence I > would not expect any XML tokenizer or parser implementation to accept > it. > > HTML is more relaxed about this, so a standalone amapersand is valid, > but you would need some kind of HTMLTokenizer and I do not know > whether there is such thing for Squeak. Anyone else knows one? > > Best regards > Jakob > > 2015-06-01 20:05 GMT+02:00 karl ramberg : > > Hi, > > I'm parsing some html docs but the XMLTokenizer chockes on a '&' > followed by > > a space in a string. > > I guess '&' is used for other stuff than a 'and' in html and it causes > error > > when used in plain text. > > > > Does anybody have fix for this? > > > > Karl > > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150602/7882ffbf/attachment.htm From lewis at mail.msen.com Mon Jun 1 22:57:01 2015 From: lewis at mail.msen.com (David T. Lewis) Date: Mon Jun 1 22:57:05 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: References: Message-ID: <20150601225701.GA59956@shell.msen.com> On Tue, Jun 02, 2015 at 12:15:22AM +0200, karl ramberg wrote: > Hi, > All windows with scroll panes are affected, AFAICT. > I'm on Spur, but I doubt that has any significance. > > When I move the mouse over a scroll bar it scrolls without clicking on it. > (Alas sometimes it stops auto-scrolling, without any clue why) I see the same thing, definitely not right. > > Is quite disorienting, stuff scrolls out of view as I move the mouse in and > out of panes. > > If this intended behavior, it must/should be made a preference. Please no preference. It's broken. Dave > > Karl > > On Mon, Jun 1, 2015 at 10:51 PM, Chris Muller wrote: > > > I can't recreate the problem. What browser are you using? > > > > The change you mention is consistent with every other type of event > > handling. It may have exposed another bug somewhere else, but I don't > > think it should be considered a bug, itself. > > > > On Mon, Jun 1, 2015 at 3:20 PM, karl ramberg > > wrote: > > > The scrolling bug is caused by this change: > > > > > > http://source.squeak.org/trunk/Morphic-cmm.984.mcz > > > > > > Morph>>handlesMouseMove: anEvent > > > "Do I want to receive mouseMove: when the hand passes over the receiver? > > > 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." > > > ---> self eventHandler ifNotNil: [^ self eventHandler handlesMouseMove: > > > anEvent]. <------- > > > anEvent hand hasSubmorphs ifTrue: [ ^ false ]. > > > (anEvent anyButtonPressed and: [ anEvent hand mouseFocus == self ]) > > ifFalse: > > > [ ^ false ]. > > > ^ true > > > > > > There seem to be some unintended behavior because of this change. > > > > > > Karl > > > > > > On Mon, Jun 1, 2015 at 10:11 PM, karl ramberg > > wrote: > > >> > > >> In latest image the mouse seem to scroll sliders just by mouse over the > > >> scroll bar. > > >> It's a very unusual behavior, and I think I would like to opt out of it. > > >> > > >> Is there a preference or is this a bug ? > > >> > > >> Karl > > > > > > > > > > > > > > > > > > > > From lewis at mail.msen.com Mon Jun 1 23:57:13 2015 From: lewis at mail.msen.com (David T. Lewis) Date: Mon Jun 1 23:57:18 2015 Subject: [squeak-dev] SqueakSSL + SAN certificates In-Reply-To: References: Message-ID: <20150601235713.GA68046@shell.msen.com> Hi Levente, Regarding your VM changes for SqueakSSL, shall I commit these to the SVN trunk repository? Ian delegated access to platforms/unix so that I can do that for you if you like. We have several Mantis entries to track your SqueakSSL work: http://bugs.squeak.org/view.php?id=7751 (Add SSL plugin) http://bugs.squeak.org/view.php?id=7793 (Memory leak in the SqueakSSL plugin on unix) http://bugs.squeak.org/view.php?id=7824 (Add TLS SNI Server Name Indication support to SqueakSSL plugin) Your latest version http://leves.web.elte.hu/squeak/SqueakSSL/ adds the SAN certificates support, so I think we should commit your latest version and close the Mantis issues. If you agree I will update the SVN files. Thanks, Dave p.s. There are still issues in SqueakSSL when sizeof(sqInt) is 8 (64 bit images) but that is a separate discussion. On Tue, May 26, 2015 at 11:55:42PM +0200, Levente Uzonyi wrote: > Hi All, > > I've implemented support for reading the domain names from the > certificate's SAN extension[1] in SqueakSSL. > The image side code is in the Inbox[2]. It is backwards compatible -- > everything works as before without the VM changes. > I've also uploaded the modified files[3][4] for the unix platform, and a > diff[5] (which somehow doesn't include the changes of the .h file). > > The VM support code for other platforms are to be done. > > These changes fix the failing SqueakSSL test in the Trunk, so I suggest > including the .mcz file in the 4.6 release. > > Levente > > [1] https://en.wikipedia.org/wiki/SubjectAltName > [2] > http://lists.squeakfoundation.org/pipermail/squeak-dev/2015-May/184581.html > [3] http://leves.web.elte.hu/squeak/SqueakSSL/SqueakSSL.h > [4] http://leves.web.elte.hu/squeak/SqueakSSL/sqUnixOpenSSL.c > [5] http://leves.web.elte.hu/squeak/SqueakSSL/diff.txt From leves at elte.hu Tue Jun 2 02:10:17 2015 From: leves at elte.hu (Levente Uzonyi) Date: Tue Jun 2 02:10:23 2015 Subject: [squeak-dev] XMLTokenizer problem with ampersand In-Reply-To: References: Message-ID: XMLTokenizer is not suitable to parse HTML documents. XML and HTML may look similar, but are very different. We used to use Soup[1] to parse HTML pages. Levente [1] http://squeaksource.com/Soup.html (watch out for versions which may not be Squeak-compatible) On Tue, 2 Jun 2015, karl ramberg wrote: > Hi,thanks for the info. > I guess I need a?HTMLTokenizer?for what I'm doing. I had issues with   as well, with the current XMLTokenizer > > Karl > > On Mon, Jun 1, 2015 at 11:01 PM, Jakob Reschke wrote: > I guess this will not help you, but a standalone ampersand is not > valid XML (it is the leader for entities, if you want to have a > literal ampersand in the text, the markup must be &), hence I > would not expect any XML tokenizer or parser implementation to accept > it. > > HTML is more relaxed about this, so a standalone amapersand is valid, > but you would need some kind of HTMLTokenizer and I do not know > whether there is such thing for Squeak. Anyone else knows one? > > Best regards > Jakob > > 2015-06-01 20:05 GMT+02:00 karl ramberg : > > Hi, > > I'm parsing some html docs but the XMLTokenizer chockes on a '&' followed by > > a space in a string. > > I guess '&' is used for other stuff than a 'and' in html and it causes error > > when used in plain text. > > > > Does anybody have fix for this? > > > > Karl > > > > From eliot.miranda at gmail.com Tue Jun 2 02:16:53 2015 From: eliot.miranda at gmail.com (Eliot Miranda) Date: Tue Jun 2 02:16:59 2015 Subject: [squeak-dev] New Cog VMs available Message-ID: ... at http://www.mirandabanda.org/files/Cog/VM/VM.r3365 CogVM source as per VMMaker.oscog-eem.1332/r3365 Newspeak Cogit: Fix the regression in implicit receiver sends caused by VMMaker.oscog-eem.1317 (fix to performance regression caused by using XCHG on x86). The implicit receiver cache uses SendNumArgsReg to refer to the cache object. Hence we must use TempReg for genPushRegisterArgsForNumArgs: in this case. So refactor to genPushRegisterArgsForNumArgs:scratchReg:, passing either TempReg or SendNumArgsReg as approprate. -- best, Eliot -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150601/949a410b/attachment.htm From leves at elte.hu Tue Jun 2 03:56:46 2015 From: leves at elte.hu (Levente Uzonyi) Date: Tue Jun 2 03:56:52 2015 Subject: [Vm-dev] Re: [squeak-dev] SqueakSSL + SAN certificates In-Reply-To: <20150601235713.GA68046@shell.msen.com> References: <20150601235713.GA68046@shell.msen.com> Message-ID: Hi David, There's a debate about how SAN certificates - and server name verification in general - should be handled[1][2]. I tend to agree with Tobias on verifying the server name in the plugin, but getting there will require further efforts - especially on the unix platform. While this version solves a particular case, and is backwards compatible on the image side, I think we should look for a better, more general solution. Levente [1] http://lists.squeakfoundation.org/pipermail/squeak-dev/2015-May/184613.html [2] http://lists.squeakfoundation.org/pipermail/squeak-dev/2015-May/184631.html On Mon, 1 Jun 2015, David T. Lewis wrote: > > Hi Levente, > > Regarding your VM changes for SqueakSSL, shall I commit these to the SVN > trunk repository? Ian delegated access to platforms/unix so that I can do > that for you if you like. > > We have several Mantis entries to track your SqueakSSL work: > > http://bugs.squeak.org/view.php?id=7751 (Add SSL plugin) > http://bugs.squeak.org/view.php?id=7793 (Memory leak in the SqueakSSL plugin on unix) > http://bugs.squeak.org/view.php?id=7824 (Add TLS SNI Server Name Indication support to SqueakSSL plugin) > > Your latest version http://leves.web.elte.hu/squeak/SqueakSSL/ adds > the SAN certificates support, so I think we should commit your latest > version and close the Mantis issues. > > If you agree I will update the SVN files. > > Thanks, > Dave > > p.s. There are still issues in SqueakSSL when sizeof(sqInt) is 8 > (64 bit images) but that is a separate discussion. > > > > On Tue, May 26, 2015 at 11:55:42PM +0200, Levente Uzonyi wrote: >> Hi All, >> >> I've implemented support for reading the domain names from the >> certificate's SAN extension[1] in SqueakSSL. >> The image side code is in the Inbox[2]. It is backwards compatible -- >> everything works as before without the VM changes. >> I've also uploaded the modified files[3][4] for the unix platform, and a >> diff[5] (which somehow doesn't include the changes of the .h file). >> >> The VM support code for other platforms are to be done. >> >> These changes fix the failing SqueakSSL test in the Trunk, so I suggest >> including the .mcz file in the 4.6 release. >> >> Levente >> >> [1] https://en.wikipedia.org/wiki/SubjectAltName >> [2] >> http://lists.squeakfoundation.org/pipermail/squeak-dev/2015-May/184581.html >> [3] http://leves.web.elte.hu/squeak/SqueakSSL/SqueakSSL.h >> [4] http://leves.web.elte.hu/squeak/SqueakSSL/sqUnixOpenSSL.c >> [5] http://leves.web.elte.hu/squeak/SqueakSSL/diff.txt > From djm1329 at san.rr.com Tue Jun 2 04:19:25 2015 From: djm1329 at san.rr.com (Douglas McPherson) Date: Tue Jun 2 04:19:30 2015 Subject: [squeak-dev] New Cog VMs available In-Reply-To: References: Message-ID: <5D0F2DAC-DEF2-47A3-BFA3-9186E1C8C402@san.rr.com> ARMv7 stack.v3 and stack.spur VMs updated accordingly. > On Jun 1, 2015, at 19:16, Eliot Miranda wrote: > > ... at http://www.mirandabanda.org/files/Cog/VM/VM.r3365 > > CogVM source as per VMMaker.oscog-eem.1332/r3365 > > Newspeak Cogit: > Fix the regression in implicit receiver sends caused by VMMaker.oscog-eem.1317 > (fix to performance regression caused by using XCHG on x86). > > The implicit receiver cache uses SendNumArgsReg to refer to the cache object. > Hence we must use TempReg for genPushRegisterArgsForNumArgs: in this case. > So refactor to genPushRegisterArgsForNumArgs:scratchReg:, passing either > TempReg or SendNumArgsReg as approprate. > -- > best, > Eliot > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150601/5f24a07a/attachment.htm From Marcel.Taeumel at hpi.de Tue Jun 2 07:47:46 2015 From: Marcel.Taeumel at hpi.de (marcel.taeumel) Date: Tue Jun 2 08:06:41 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: <20150601225701.GA59956@shell.msen.com> References: <20150601225701.GA59956@shell.msen.com> Message-ID: <1433231266377-4829903.post@n4.nabble.com> Chris' change is correct. The expectations in Slider >> #initializeSlider are kind of specific and do not match anymore. There, it is assumed that mouse-move events will only come after a mouse-down event -- not every time. The thing is that there may be many other places where this is assumed. Hmmm... I propose this change: fix-mouse-move-bug.cs It makes #wantsEveryMouseMove functional again and adds it to the EventHandler, too. It also duplicates the additional checks regarding mouse focus, submorphs, button down, etc. Best, Marcel -- View this message in context: http://forum.world.st/BUG-Automagic-scrolling-tp4829828p4829903.html Sent from the Squeak - Dev mailing list archive at Nabble.com. From Marcel.Taeumel at hpi.de Tue Jun 2 07:53:11 2015 From: Marcel.Taeumel at hpi.de (marcel.taeumel) Date: Tue Jun 2 08:12:09 2015 Subject: [squeak-dev] Re: Bug: list filtering is acting on multiple lists at once In-Reply-To: References: Message-ID: <1433231591878-4829904.post@n4.nabble.com> Cannot reproduce. The only thing that happens is that the selection in the category list might change due to the filter and hence the message list updates, too. Best, Marcel -- View this message in context: http://forum.world.st/Bug-list-filtering-is-acting-on-multiple-lists-at-once-tp4829819p4829904.html Sent from the Squeak - Dev mailing list archive at Nabble.com. From edgardec2005 at gmail.com Tue Jun 2 09:35:05 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Tue Jun 2 09:35:13 2015 Subject: [squeak-dev] Cuis/GreenNeon blog post In-Reply-To: <5832F289-C9D0-4F02-A229-F2516C8FFF13@gmail.com> Message-ID: On 6/1/15, 10:54 AM, "Chris Cunnington" wrote: > A blog post about Cuis, WebClient and GreenNeon. > > https://websela.wordpress.com/ > > Chris Great, I follow Edgar -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150602/004bb3dd/attachment.htm From karlramberg at gmail.com Tue Jun 2 10:53:04 2015 From: karlramberg at gmail.com (karl ramberg) Date: Tue Jun 2 10:53:08 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: <1433231266377-4829903.post@n4.nabble.com> References: <20150601225701.GA59956@shell.msen.com> <1433231266377-4829903.post@n4.nabble.com> Message-ID: Hi, Change set works, Marcel :-) Thanks, Karl On Tue, Jun 2, 2015 at 9:47 AM, marcel.taeumel wrote: > Chris' change is correct. The expectations in Slider >> #initializeSlider > are > kind of specific and do not match anymore. There, it is assumed that > mouse-move events will only come after a mouse-down event -- not every > time. > The thing is that there may be many other places where this is assumed. > Hmmm... > > I propose this change: fix-mouse-move-bug.cs > > > It makes #wantsEveryMouseMove functional again and adds it to the > EventHandler, too. It also duplicates the additional checks regarding mouse > focus, submorphs, button down, etc. > > Best, > Marcel > > > > -- > View this message in context: > http://forum.world.st/BUG-Automagic-scrolling-tp4829828p4829903.html > Sent from the Squeak - Dev mailing list archive at Nabble.com. > > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150602/7a3c382e/attachment.htm From lewis at mail.msen.com Tue Jun 2 12:05:11 2015 From: lewis at mail.msen.com (David T. Lewis) Date: Tue Jun 2 12:05:14 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: References: <20150601225701.GA59956@shell.msen.com> <1433231266377-4829903.post@n4.nabble.com> Message-ID: <20150602120511.GA97335@shell.msen.com> It looks good to me too :-) Dave On Tue, Jun 02, 2015 at 12:53:04PM +0200, karl ramberg wrote: > Hi, > Change set works, Marcel :-) > > Thanks, > Karl > > On Tue, Jun 2, 2015 at 9:47 AM, marcel.taeumel > wrote: > > > Chris' change is correct. The expectations in Slider >> #initializeSlider > > are > > kind of specific and do not match anymore. There, it is assumed that > > mouse-move events will only come after a mouse-down event -- not every > > time. > > The thing is that there may be many other places where this is assumed. > > Hmmm... > > > > I propose this change: fix-mouse-move-bug.cs > > > > > > It makes #wantsEveryMouseMove functional again and adds it to the > > EventHandler, too. It also duplicates the additional checks regarding mouse > > focus, submorphs, button down, etc. > > > > Best, > > Marcel > > > > > > > > -- > > View this message in context: > > http://forum.world.st/BUG-Automagic-scrolling-tp4829828p4829903.html > > Sent from the Squeak - Dev mailing list archive at Nabble.com. > > > > > From brasspen at gmail.com Tue Jun 2 13:07:34 2015 From: brasspen at gmail.com (Chris Cunnington) Date: Tue Jun 2 13:07:43 2015 Subject: [squeak-dev] Re: [Cuis] Cuis/GreenNeon blog post In-Reply-To: <556DA92E.8060705@jvuletich.org> References: <5832F289-C9D0-4F02-A229-F2516C8FFF13@gmail.com> <556DA92E.8060705@jvuletich.org> Message-ID: <15643114-CD7F-4DB5-8DDD-C4D9B7D2FFE3@gmail.com> > On Jun 2, 2015, at 9:01 AM, Juan Vuletich wrote: > > Hi Chris, > > Thank you very much for taking the time to rebuild Cuis-GreenNeon and write about it! > > As you know, we are interested in experimenting with it, and maybe adopt it for some projects. > Can we have your permission to take the Cuis image you built, extract your code, and publish it as .pck.st package(s) for Cuis, under the MIT license? Ongoing development could then be done by anyone interested, and everyone would be free to use it. Absolutely. Please take it and use it in any way you think is worthwhile. I?d rather you packaged it in a way you think is useful than my trying to guess what it is you need. Everybody on your list is a better programmer than I am and I look forward to learning from what they decide to change. You have my unreserved permission do take the code and use it in any way that could be useful to you. Chris > > Thanks, > Juan Vuletichj > > > On 6/1/2015 10:54 AM, Chris Cunnington wrote: >> >> A blog post about Cuis, WebClient and GreenNeon. >> >> https://websela.wordpress.com/ >> >> Chris >> >> _______________________________________________ >> Cuis mailing list >> Cuis@jvuletich.org >> http://jvuletich.org/mailman/listinfo/cuis_jvuletich.org > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150602/2a3362f7/attachment-0001.htm From asqueaker at gmail.com Tue Jun 2 16:17:51 2015 From: asqueaker at gmail.com (Chris Muller) Date: Tue Jun 2 16:17:56 2015 Subject: [squeak-dev] XMLTokenizer problem with ampersand In-Reply-To: References: Message-ID: On Mon, Jun 1, 2015 at 9:10 PM, Levente Uzonyi wrote: > XMLTokenizer is not suitable to parse HTML documents. XML and HTML may look > similar, but are very different. > We used to use Soup[1] to parse HTML pages. Have you used Todd Blanchard's "HTML & CSS Validating Parser" [1], if so how does it compare to Soup? [1] -- http://www.squeaksource.com/htmlcssparser.html From commits at source.squeak.org Tue Jun 2 17:09:09 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Tue Jun 2 17:09:14 2015 Subject: [squeak-dev] The Trunk: Kernel-eem.929.mcz Message-ID: Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.929.mcz ==================== Summary ==================== Name: Kernel-eem.929 Author: eem Time: 2 June 2015, 10:08:30.877 am UUID: c05a273c-9ef2-433f-9106-012dff5a0a4d Ancestors: Kernel-eem.928 Fix computation of prior position in new printMethodChunkHistorically:on:moveSource:toFile: =============== Diff against Kernel-eem.928 =============== Item was changed: ----- Method: ClassDescription>>printMethodChunkHistorically:on:moveSource:toFile: (in category 'fileIn/Out') ----- printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex "Copy all source codes historically for the method associated with selector onto the fileStream. If moveSource is true, then also set the source code pointer of the method. N.B. fileIndex is interpreted as follows, 0 => just a fileOut; 1 => condensing sources; 2 => condensing changes; therefore only changes on the chnages file before the last version in the sources file are recorded." + | preamble method newPos category changeList priorPos index | - | preamble method newPos category changeList prior index | category := self organization categoryOfElement: selector. preamble := self name , ' methodsFor: ', category asString printString. method := self methodDict at: selector. (method filePosition = 0 or: [method fileIndex = 0 or: [(SourceFiles at: method fileIndex) isNil]]) ifTrue: "no source; must decompile" [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr. outStream nextChunkPut: method decompileString. outStream nextChunkPut: ' '; cr] ifFalse: [changeList := ChangeSet directAncestryOfVersions: (ChangeSet scanVersionsOf: method class: self meta: self isMeta category: category selector: selector). + newPos := priorPos := nil. - newPos := prior := nil. (fileIndex = 2 "condensing changes; select changes file code and find last sources file change" and: [(index := changeList findFirst: [:chgRec| chgRec fileIndex = 1]) > 0]) ifTrue: + [priorPos := SourceFiles + sourcePointerFromFileIndex: 1 + andPosition: (changeList at: index) position. - [prior := changeList at: index. changeList := changeList copyFrom: 1 to: index - 1]. changeList reverseDo: [:chgRec| chgRec file closed ifTrue: [chgRec file reopen; setToEnd]. outStream copyPreamble: preamble from: chgRec file at: chgRec position. + priorPos ifNotNil: - prior ifNotNil: [outStream position: outStream position - 2; + nextPutAll: ' prior: '; print: priorPos; nextPut: $!!; cr]. - nextPutAll: ' prior: '; - print: (SourceFiles - sourcePointerFromFileIndex: prior fileIndex - andPosition: prior position); - nextPut: $!!; cr]. "Copy the method chunk" newPos := outStream position. outStream copyMethodChunkFrom: chgRec file at: chgRec position. chgRec file skipSeparators. "The following chunk may have ]style[" chgRec file peek == $] ifTrue: [outStream cr; copyMethodChunkFrom: chgRec file]. outStream nextChunkPut: ' '; cr. chgRec position: newPos. + priorPos := SourceFiles + sourcePointerFromFileIndex: fileIndex + andPosition: newPos]. - prior := chgRec]. moveSource ifTrue: [method setSourcePosition: newPos inFile: fileIndex]]. ^outStream! From commits at source.squeak.org Tue Jun 2 21:55:06 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Tue Jun 2 21:55:09 2015 Subject: [squeak-dev] Daily Commit Log Message-ID: <20150602215506.9652.qmail@box4.squeakfoundation.org> Changes to Trunk (http://source.squeak.org/trunk.html) in the last 24 hours: http://lists.squeakfoundation.org/pipermail/packages/2015-June/008739.html Name: Kernel-eem.929 Ancestors: Kernel-eem.928 Fix computation of prior position in new printMethodChunkHistorically:on:moveSource:toFile: ============================================= http://lists.squeakfoundation.org/pipermail/packages/2015-June/008740.html Name: Kernel.spur-eem.929 Ancestors: Kernel-eem.929, Kernel.spur-eem.928 Kernel-eem.929 patched for Spur by SpurBootstrapMonticelloPackagePatcher Cog-eem.268 Fix computation of prior position in new printMethodChunkHistorically:on:moveSource:toFile: ============================================= From commits at source.squeak.org Wed Jun 3 05:30:42 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Wed Jun 3 05:30:43 2015 Subject: [squeak-dev] The Trunk: Morphic-mt.987.mcz Message-ID: Marcel Taeumel uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-mt.987.mcz ==================== Summary ==================== Name: Morphic-mt.987 Author: mt Time: 3 June 2015, 7:30:01.792 am UUID: 61893b51-713a-044a-9f42-a9682768f6d1 Ancestors: Morphic-cmm.986 Fixes a regression in scroll bars that "automagically" scrolled on mouse move due to the latest changes. Makes #wantsEveryMouseMove functional again and adds it to the EventHandler, too. It also duplicates the additional checks regarding mouse focus, submorphs, button down, etc. =============== Diff against Morphic-cmm.986 =============== Item was changed: Object subclass: #EventHandler + instanceVariableNames: 'mouseDownRecipient mouseDownSelector mouseMoveRecipient mouseMoveSelector mouseStillDownRecipient mouseStillDownSelector mouseUpRecipient mouseUpSelector mouseEnterRecipient mouseEnterSelector mouseLeaveRecipient mouseLeaveSelector mouseEnterDraggingRecipient mouseEnterDraggingSelector mouseLeaveDraggingRecipient mouseLeaveDraggingSelector keyStrokeRecipient keyStrokeSelector keyUpRecipient keyUpSelector keyDownRecipient keyDownSelector valueParameter startDragRecipient startDragSelector doubleClickSelector doubleClickRecipient doubleClickTimeoutSelector doubleClickTimeoutRecipient clickSelector clickRecipient keyboardFocusChangeRecipient keyboardFocusChangeSelector wantsEveryMouseMove' - instanceVariableNames: 'mouseDownRecipient mouseDownSelector mouseMoveRecipient mouseMoveSelector mouseStillDownRecipient mouseStillDownSelector mouseUpRecipient mouseUpSelector mouseEnterRecipient mouseEnterSelector mouseLeaveRecipient mouseLeaveSelector mouseEnterDraggingRecipient mouseEnterDraggingSelector mouseLeaveDraggingRecipient mouseLeaveDraggingSelector keyStrokeRecipient keyStrokeSelector keyUpRecipient keyUpSelector keyDownRecipient keyDownSelector valueParameter startDragRecipient startDragSelector doubleClickSelector doubleClickRecipient doubleClickTimeoutSelector doubleClickTimeoutRecipient clickSelector clickRecipient keyboardFocusChangeRecipient keyboardFocusChangeSelector' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !EventHandler commentStamp: '' prior: 0! Events in Morphic originate in a Hand, pass to a target morph, and are then dispatched by an EventHandler. EventHandlers support redirection of mouse and keyboard activity by specifying and independent recipient object and message selector for each of the possible events. In addition each eventHandler can supply an optional value parameter for distinguishing between, eg, events from a number of otherwise identical source morphs. The basic protocol of an event handler is to receive a message of the form mouseDown: event in: targetMorph and redirect this as one of mouseDownRecipient perform: mouseDownSelector0 mouseDownRecipient perform: mouseDownSelector1 with: event mouseDownRecipient perform: mouseDownSelector2 with: event with: targetMorph mouseDownRecipient perform: mouseDownSelector3 with: event with: targetMorph with: valueParameter depending on the arity of the mouseDownSelector. ! Item was changed: ----- Method: EventHandler>>handlesMouseMove: (in category 'testing') ----- handlesMouseMove: evt + + ^ self wantsEveryMouseMove == true + or: [((((mouseMoveRecipient notNil and: [mouseMoveSelector notNil]) + and: [evt hand hasSubmorphs not]) + and: [evt anyButtonPressed]) + and: [evt hand mouseFocus notNil]) + and: [evt hand mouseFocus eventHandler == self]]! - ^mouseMoveRecipient notNil and:[mouseMoveSelector notNil]! Item was added: + ----- Method: EventHandler>>wantsEveryMouseMove (in category 'access') ----- + wantsEveryMouseMove + + ^ wantsEveryMouseMove! Item was added: + ----- Method: EventHandler>>wantsEveryMouseMove: (in category 'access') ----- + wantsEveryMouseMove: aBoolean + + wantsEveryMouseMove := aBoolean.! Item was changed: ----- Method: Morph>>handlesMouseMove: (in category 'event handling') ----- handlesMouseMove: anEvent "Do I want to receive mouseMove: when the hand passes over the receiver? 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." self eventHandler ifNotNil: [^ self eventHandler handlesMouseMove: anEvent]. + self wantsEveryMouseMove ifTrue: [^ true]. anEvent hand hasSubmorphs ifTrue: [ ^ false ]. (anEvent anyButtonPressed and: [ anEvent hand mouseFocus == self ]) ifFalse: [ ^ false ]. ^ true! Item was removed: - ----- Method: ProportionalSplitterMorph>>wantsEveryMouseMove (in category 'events') ----- - wantsEveryMouseMove - - ^ true! From Marcel.Taeumel at hpi.de Wed Jun 3 06:37:22 2015 From: Marcel.Taeumel at hpi.de (marcel.taeumel) Date: Wed Jun 3 06:56:25 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: <20150602120511.GA97335@shell.msen.com> References: <20150601225701.GA59956@shell.msen.com> <1433231266377-4829903.post@n4.nabble.com> <20150602120511.GA97335@shell.msen.com> Message-ID: <1433313442417-4830115.post@n4.nabble.com> http://forum.world.st/The-Trunk-Morphic-mt-987-mcz-td4830105.html Best, Marcel -- View this message in context: http://forum.world.st/BUG-Automagic-scrolling-tp4829828p4830115.html Sent from the Squeak - Dev mailing list archive at Nabble.com. From karlramberg at gmail.com Wed Jun 3 17:57:21 2015 From: karlramberg at gmail.com (karl ramberg) Date: Wed Jun 3 17:57:27 2015 Subject: [squeak-dev] Bitmap DejaVu sans punktuation mark sizes Message-ID: I really like the Bitmap DejaVu sans font. I have basically all text displayed in size 9. That size i very readable and give I get enough text on screen to get a good workflow. But I constantly miss punctuation because a full stop is like one pixel. And colon and semicolon are also very small. To add to that there is very tight kerning around the punctuation marks. It's easy to miss and it causes mild grief on my part. With the high resolution of today's monitors I think a bigger size of these punctuation marks would be good. Any thoughts ? Karl -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150603/72ff2068/attachment.htm From asqueaker at gmail.com Wed Jun 3 20:05:58 2015 From: asqueaker at gmail.com (Chris Muller) Date: Wed Jun 3 20:06:02 2015 Subject: [squeak-dev] Re: BUG Automagic scrolling ? In-Reply-To: <1433313442417-4830115.post@n4.nabble.com> References: <20150601225701.GA59956@shell.msen.com> <1433231266377-4829903.post@n4.nabble.com> <20150602120511.GA97335@shell.msen.com> <1433313442417-4830115.post@n4.nabble.com> Message-ID: The color picker appears fine again too with this. Thanks Marcel! On Wed, Jun 3, 2015 at 1:37 AM, marcel.taeumel wrote: > http://forum.world.st/The-Trunk-Morphic-mt-987-mcz-td4830105.html > > Best, > Marcel > > > > -- > View this message in context: http://forum.world.st/BUG-Automagic-scrolling-tp4829828p4830115.html > Sent from the Squeak - Dev mailing list archive at Nabble.com. > From asqueaker at gmail.com Wed Jun 3 20:09:59 2015 From: asqueaker at gmail.com (Chris Muller) Date: Wed Jun 3 20:10:01 2015 Subject: [squeak-dev] Bitmap DejaVu sans punktuation mark sizes In-Reply-To: References: Message-ID: On Wed, Jun 3, 2015 at 12:57 PM, karl ramberg wrote: > I really like the Bitmap DejaVu sans font. I have basically all text > displayed in size 9. That size i very readable and give I get enough text on > screen to get a good workflow. > > But I constantly miss punctuation because a full stop is like one pixel. And > colon and semicolon are also very small. > To add to that there is very tight kerning around the punctuation marks. > > It's easy to miss and it causes mild grief on my part. > > With the high resolution of today's monitors I think a bigger size of these > punctuation marks would be good. > > Any thoughts ? I've noticed that the period was pretty small for my eyes too. It seems better in Accusf we could use that the fonts...? From bert at freudenbergs.de Wed Jun 3 21:40:45 2015 From: bert at freudenbergs.de (Bert Freudenberg) Date: Wed Jun 3 21:40:48 2015 Subject: [squeak-dev] Bitmap DejaVu sans punktuation mark sizes In-Reply-To: References: Message-ID: <2652CAC8-D94A-4961-92BE-56AB57AE7DC8@freudenbergs.de> Skipped content of type multipart/alternative-------------- next part -------------- A non-text attachment was scrubbed... Name: smime.p7s Type: application/pkcs7-signature Size: 4115 bytes Desc: not available Url : http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150603/6a3e8463/smime.bin From commits at source.squeak.org Wed Jun 3 21:55:04 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Wed Jun 3 21:55:06 2015 Subject: [squeak-dev] Daily Commit Log Message-ID: <20150603215504.29515.qmail@box4.squeakfoundation.org> Changes to Trunk (http://source.squeak.org/trunk.html) in the last 24 hours: http://lists.squeakfoundation.org/pipermail/packages/2015-June/008741.html Name: Morphic-mt.987 Ancestors: Morphic-cmm.986 Fixes a regression in scroll bars that "automagically" scrolled on mouse move due to the latest changes. Makes #wantsEveryMouseMove functional again and adds it to the EventHandler, too. It also duplicates the additional checks regarding mouse focus, submorphs, button down, etc. ============================================= From karlramberg at gmail.com Wed Jun 3 22:11:53 2015 From: karlramberg at gmail.com (karl ramberg) Date: Wed Jun 3 22:11:56 2015 Subject: [squeak-dev] Bitmap DejaVu sans punktuation mark sizes In-Reply-To: <2652CAC8-D94A-4961-92BE-56AB57AE7DC8@freudenbergs.de> References: <2652CAC8-D94A-4961-92BE-56AB57AE7DC8@freudenbergs.de> Message-ID: A fix for this would be great. My eye are getting worse by the day it feels like. The bold punctuation of size 9 Bitmap DejaVu is much more legible. Karl On Wed, Jun 3, 2015 at 11:40 PM, Bert Freudenberg wrote: > > On 03.06.2015, at 19:57, karl ramberg wrote: > > I really like the Bitmap DejaVu sans font. I have basically all text > displayed in size 9. That size i very readable and give I get enough text > on screen to get a good workflow. > > But I constantly miss punctuation because a full stop is like one pixel. > And colon and semicolon are also very small. > To add to that there is very tight kerning around the punctuation marks. > > It's easy to miss and it causes mild grief on my part. > > With the high resolution of today's monitors I think a bigger size of > these punctuation marks would be good. > > Any thoughts ? > > Karl > > > +1 > > I remember fixing this in one of my images. Can?t remember which one, > unfortunately :( > > - Bert - > > > > > > > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/d7adeeab/attachment.htm From tim at rowledge.org Wed Jun 3 22:51:22 2015 From: tim at rowledge.org (tim Rowledge) Date: Wed Jun 3 22:51:27 2015 Subject: [squeak-dev] Bitmap DejaVu sans punktuation mark sizes In-Reply-To: References: <2652CAC8-D94A-4961-92BE-56AB57AE7DC8@freudenbergs.de> Message-ID: On 03-06-2015, at 3:11 PM, karl ramberg wrote: > A fix for this would be great. > My eye are getting worse by the day it feels like. Welcome to over-30-land. This is another reason we really ought to try to move away from predominantly pixel based graphics to vector based - scaling to suit the user needs works so much better. We have had the basic capability for at least a decade (remember ?pooh??) and now there is Nile to add to the mix. tim -- tim Rowledge; tim@rowledge.org; http://www.rowledge.org/tim Useful random insult:- He has a tenuous grip on the obvious. From commits at source.squeak.org Thu Jun 4 07:59:48 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Thu Jun 4 07:59:50 2015 Subject: [squeak-dev] The Trunk: HelpSystem-Core-kfr.75.mcz Message-ID: Marcel Taeumel uploaded a new version of HelpSystem-Core to project The Trunk: http://source.squeak.org/trunk/HelpSystem-Core-kfr.75.mcz ==================== Summary ==================== Name: HelpSystem-Core-kfr.75 Author: kfr Time: 13 May 2015, 1:52:38.849 pm UUID: 5b487f7f-b174-5343-894a-aff28511d4fa Ancestors: HelpSystem-Core-mt.74 HelpBrowser>>accept: changed so it works. The changed topic is compiled but the current topic loaded in the HelpBrowser is not updated =============== Diff against HelpSystem-Core-mt.74 =============== Item was changed: ----- Method: HelpBrowser>>accept: (in category 'actions') ----- accept: text "Accept edited text. Compile it into a HelpTopic" + | code topicClass topicMethod updatedTopic | + "true ifTrue:[^self inform: 'Not implemented yet.', String cr, 'Make new help pages in the browser for the time being']." + (self find: (self currentTopic contents copyFrom: 1 to: 20)) asArray + ifNotEmpty: [:refs | - | code topicClass topicMethod | - true ifTrue:[^self inform: 'Not implemented yet.', String cr, 'Make new help pages in the browser for the time being']. - (self find: self topic contents) asArray ifNotEmpty: [:refs | topicClass := refs first actualClass theNonMetaClass. topicMethod := refs first selector]. code := String streamContents:[:s| s nextPutAll: topicMethod. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', topicMethod storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', currentTopic title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. + updatedTopic := topicClass class - topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethod) ifNil:['pages']). + - self flag: #fixme. "mt: Update will not work because the topic builder eagerly cached all the contents and lost track of its origins. We need to get rid of the topic builders and create topic contents lazily resp. live." + self currentTopic: updatedTopic. - self changed: #toplevelTopics.. self changed: #currentTopic. self changed: #topicContents. ! From commits at source.squeak.org Thu Jun 4 08:00:19 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Thu Jun 4 08:00:21 2015 Subject: [squeak-dev] The Trunk: HelpSystem-Core-kfr.76.mcz Message-ID: Marcel Taeumel uploaded a new version of HelpSystem-Core to project The Trunk: http://source.squeak.org/trunk/HelpSystem-Core-kfr.76.mcz ==================== Summary ==================== Name: HelpSystem-Core-kfr.76 Author: kfr Time: 13 May 2015, 6:53:53.29 pm UUID: fbad033b-7c29-0748-bdb5-02a02dff4cf7 Ancestors: HelpSystem-Core-kfr.75 Added a check/ bail out for non editable help topics =============== Diff against HelpSystem-Core-kfr.75 =============== Item was changed: ----- Method: HelpBrowser>>accept: (in category 'actions') ----- accept: text "Accept edited text. Compile it into a HelpTopic" | code topicClass topicMethod updatedTopic | "true ifTrue:[^self inform: 'Not implemented yet.', String cr, 'Make new help pages in the browser for the time being']." (self find: (self currentTopic contents copyFrom: 1 to: 20)) asArray + ifNotEmpty: [:refs | - ifNotEmpty: [:refs | topicClass := refs first actualClass theNonMetaClass. topicMethod := refs first selector]. + topicClass = nil ifTrue:[^self inform: 'This help topic can not be edited here']. - code := String streamContents:[:s| s nextPutAll: topicMethod. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', topicMethod storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', currentTopic title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. updatedTopic := topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethod) ifNil:['pages']). self flag: #fixme. "mt: Update will not work because the topic builder eagerly cached all the contents and lost track of its origins. We need to get rid of the topic builders and create topic contents lazily resp. live." self currentTopic: updatedTopic. self changed: #toplevelTopics.. self changed: #currentTopic. self changed: #topicContents. ! From commits at source.squeak.org Thu Jun 4 08:00:27 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Thu Jun 4 08:00:31 2015 Subject: [squeak-dev] The Trunk: HelpSystem-Core-kfr.77.mcz Message-ID: Marcel Taeumel uploaded a new version of HelpSystem-Core to project The Trunk: http://source.squeak.org/trunk/HelpSystem-Core-kfr.77.mcz ==================== Summary ==================== Name: HelpSystem-Core-kfr.77 Author: kfr Time: 14 May 2015, 10:14:49.361 am UUID: b5acbf22-bb99-744b-a8b7-9fa05787ddec Ancestors: HelpSystem-Core-kfr.76 Replace a edited help topic in HelpBrowser with a new one. There is still a bug that the updated topic changes place in the topic list I'm also a little confused why there is two hierachies with the help topics in rootTopic and topLevelTopics =============== Diff against HelpSystem-Core-kfr.76 =============== Item was changed: Model subclass: #HelpBrowser + instanceVariableNames: 'rootTopic currentTopic result searchTopic topicPath toplevelTopics oldTopic' - instanceVariableNames: 'rootTopic currentTopic result searchTopic topicPath toplevelTopics' classVariableNames: 'DefaultHelpBrowser' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpBrowser commentStamp: 'tbn 3/8/2010 09:33' prior: 0! A HelpBrowser is used to display a hierarchy of help topics and their contents. Instance Variables rootTopic: window: treeMorph: contentMorph: rootTopic - xxxxx window - xxxxx treeMorph - xxxxx contentMorph - xxxxx ! Item was changed: ----- Method: HelpBrowser>>accept: (in category 'actions') ----- accept: text "Accept edited text. Compile it into a HelpTopic" | code topicClass topicMethod updatedTopic | - "true ifTrue:[^self inform: 'Not implemented yet.', String cr, 'Make new help pages in the browser for the time being']." (self find: (self currentTopic contents copyFrom: 1 to: 20)) asArray ifNotEmpty: [:refs | topicClass := refs first actualClass theNonMetaClass. topicMethod := refs first selector]. topicClass = nil ifTrue:[^self inform: 'This help topic can not be edited here']. code := String streamContents:[:s| s nextPutAll: topicMethod. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', topicMethod storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', currentTopic title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. + topicClass class - updatedTopic := topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethod) ifNil:['pages']). + updatedTopic := topicClass perform: topicMethod. + oldTopic := currentTopic. + "self inTopic: self rootTopic replaceCurrentTopicWith: updatedTopic". + self toplevelTopics do:[ :each | self inTopic: each replaceCurrentTopicWith: updatedTopic]. - - self flag: #fixme. "mt: Update will not work because the topic builder eagerly cached all the contents and lost track of its origins. We need to get rid of the topic builders and create topic contents lazily resp. live." - self currentTopic: updatedTopic. self changed: #toplevelTopics.. self changed: #currentTopic. self changed: #topicContents. ! Item was added: + ----- Method: HelpBrowser>>inTopic:replaceCurrentTopicWith: (in category 'actions') ----- + inTopic: parentTopic replaceCurrentTopicWith: aNewTopic + + parentTopic subtopics + do: [ :sub | self inTopic: parentTopic replaceSubtopic: sub with: aNewTopic]! Item was added: + ----- Method: HelpBrowser>>inTopic:replaceSubtopic:with: (in category 'actions') ----- + inTopic: parentTopic replaceSubtopic: aTopic with: aNewTopic + | i | + + (aTopic = oldTopic) + ifTrue: [ i := parentTopic subtopics indexOf: aTopic. + parentTopic subtopics at: i put: aNewTopic. ^self ]. + + aTopic subtopics + do: [ :sub | self inTopic: aTopic replaceSubtopic: sub with: aNewTopic]! From commits at source.squeak.org Thu Jun 4 08:00:47 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Thu Jun 4 08:00:49 2015 Subject: [squeak-dev] The Trunk: HelpSystem-Core-mt.78.mcz Message-ID: Marcel Taeumel uploaded a new version of HelpSystem-Core to project The Trunk: http://source.squeak.org/trunk/HelpSystem-Core-mt.78.mcz ==================== Summary ==================== Name: HelpSystem-Core-mt.78 Author: mt Time: 14 May 2015, 6:45:57.427 pm UUID: d3d02275-f61e-8f4f-91e0-5dcf9b37c8d5 Ancestors: HelpSystem-Core-kfr.77 Class-based help topics are editable again. Help browser updates correctly after edits. =============== Diff against HelpSystem-Core-kfr.77 =============== Item was added: + ----- Method: AbstractHelpTopic>>isEditable (in category 'testing') ----- + isEditable + + ^ false! Item was added: + ----- Method: AbstractHelpTopic>>refresh (in category 'updating') ----- + refresh + "Do nothing."! Item was added: + ----- Method: ClassBasedHelpTopic>>isEditable (in category 'testing') ----- + isEditable + ^ true! Item was added: + ----- Method: ClassBasedHelpTopic>>refresh (in category 'updating') ----- + refresh + + self updateSubtopics. + self changed: #subtopicsUpdated.! Item was changed: ----- Method: ClassBasedHelpTopic>>updateSubtopics (in category 'updating') ----- updateSubtopics | pages | pages := (self helpClass pages collect: [:pageSelectorOrClassName | (Smalltalk hasClassNamed: pageSelectorOrClassName asString) ifTrue: [Smalltalk classNamed: pageSelectorOrClassName asString] ifFalse: [pageSelectorOrClassName]]) asOrderedCollection. self helpClass subclasses select: [:cls | cls ignore not] thenDo: [:cls | pages addIfNotPresent: cls]. ^ subtopics := pages withIndexCollect: [:pageSelectorOrClass :priority | pageSelectorOrClass isBehavior + ifFalse: [(self helpClass perform: pageSelectorOrClass) priority: priority - pages size; key: pageSelectorOrClass; yourself] - ifFalse: [(self helpClass perform: pageSelectorOrClass) priority: priority - pages size; yourself] ifTrue: [pageSelectorOrClass asHelpTopic]]! Item was changed: Model subclass: #HelpBrowser + instanceVariableNames: 'rootTopic currentTopic currentParentTopic result searchTopic topicPath toplevelTopics oldTopic' - instanceVariableNames: 'rootTopic currentTopic result searchTopic topicPath toplevelTopics oldTopic' classVariableNames: 'DefaultHelpBrowser' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpBrowser commentStamp: 'tbn 3/8/2010 09:33' prior: 0! A HelpBrowser is used to display a hierarchy of help topics and their contents. Instance Variables rootTopic: window: treeMorph: contentMorph: rootTopic - xxxxx window - xxxxx treeMorph - xxxxx contentMorph - xxxxx ! Item was changed: ----- Method: HelpBrowser>>accept: (in category 'actions') ----- accept: text "Accept edited text. Compile it into a HelpTopic" + | code parent topicClass topicMethod | + (self currentParentTopic isNil or: [self currentParentTopic isEditable not]) + ifTrue: [^ self inform: 'This help topic cannot be edited.']. + + parent := self currentParentTopic. + topicClass := parent helpClass. + topicMethod := self currentTopic key. + - | code topicClass topicMethod updatedTopic | - (self find: (self currentTopic contents copyFrom: 1 to: 20)) asArray - ifNotEmpty: [:refs | - topicClass := refs first actualClass theNonMetaClass. - topicMethod := refs first selector]. - topicClass = nil ifTrue:[^self inform: 'This help topic can not be edited here']. code := String streamContents:[:s| s nextPutAll: topicMethod. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', topicMethod storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', currentTopic title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethod) ifNil:['pages']). + + parent refresh. + self currentTopic: (parent subtopics detect: [:t | t key = topicMethod]).! - updatedTopic := topicClass perform: topicMethod. - oldTopic := currentTopic. - "self inTopic: self rootTopic replaceCurrentTopicWith: updatedTopic". - self toplevelTopics do:[ :each | self inTopic: each replaceCurrentTopicWith: updatedTopic]. - self changed: #toplevelTopics.. - self changed: #currentTopic. - self changed: #topicContents. - ! Item was changed: ----- Method: HelpBrowser>>buildWith: (in category 'toolbuilder') ----- buildWith: builder | windowSpec treeSpec textSpec searchSpec | windowSpec := builder pluggableWindowSpec new. windowSpec model: self; children: OrderedCollection new; label: #label. searchSpec := builder pluggableInputFieldSpec new. searchSpec model: self; getText: #searchTerm; setText: #searchTerm:; help: 'Search...'; frame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (Preferences standardDefaultTextFont height * 2))). windowSpec children add: searchSpec. treeSpec := builder pluggableTreeSpec new. treeSpec model: self; nodeClass: HelpTopicListItemWrapper; roots: #toplevelTopics; getSelected: #currentTopic; setSelected: #currentTopic:; getSelectedPath: #currentTopicPath; + setSelectedParent: #currentParentTopic:; autoDeselect: false; frame: (LayoutFrame fractions: (0@0 corner: 0.3@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)). windowSpec children add: treeSpec. textSpec := builder pluggableTextSpec new. textSpec model: self; getText: #topicContents; setText: #accept:; menu: #codePaneMenu:shifted:; frame: (LayoutFrame fractions: (0.3@0.0 corner: 1@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)). windowSpec children add: textSpec. ^ builder build: windowSpec! Item was added: + ----- Method: HelpBrowser>>currentParentTopic (in category 'accessing') ----- + currentParentTopic + + ^ currentParentTopic! Item was added: + ----- Method: HelpBrowser>>currentParentTopic: (in category 'accessing') ----- + currentParentTopic: aHelpTopic + + currentParentTopic := aHelpTopic.! Item was added: + ----- Method: HelpTopic>>key (in category 'accessing') ----- + key + + ^ key! Item was added: + ----- Method: HelpTopic>>key: (in category 'accessing') ----- + key: aSymbol + + key := aSymbol.! Item was changed: PluggableListItemWrapper subclass: #HelpTopicListItemWrapper + instanceVariableNames: 'parent' - instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpTopicListItemWrapper commentStamp: 'tbn 3/8/2010 09:30' prior: 0! This class implements a list item wrapper for help topics. Instance Variables ! Item was added: + ----- Method: HelpTopicListItemWrapper class>>with:model:parent: (in category 'as yet unclassified') ----- + with: anObject model: aModel parent: aParent + + ^self new + setItem: anObject model: aModel parent: aParent + ! Item was changed: ----- Method: HelpTopicListItemWrapper>>contents (in category 'accessing') ----- contents ^self item subtopics sorted collect: [ :each | + HelpTopicListItemWrapper with: each model: self model parent: self] - HelpTopicListItemWrapper with: each model: self model] ! Item was added: + ----- Method: HelpTopicListItemWrapper>>parent (in category 'accessing') ----- + parent + + ^ parent! Item was added: + ----- Method: HelpTopicListItemWrapper>>parent: (in category 'accessing') ----- + parent: aWrapper + + parent := aWrapper.! Item was added: + ----- Method: HelpTopicListItemWrapper>>setItem:model:parent: (in category 'initialization') ----- + setItem: anObject model: aModel parent: itemParent + + self parent: itemParent. + self setItem: anObject model: aModel.! Item was added: + ----- Method: HelpTopicListItemWrapper>>update: (in category 'accessing') ----- + update: aspect + + super update: aspect. + + "Map the domain-specific aspect to a framework-specific one." + aspect = #subtopicsUpdated ifTrue: [ + self changed: #contents].! From edgardec2005 at gmail.com Thu Jun 4 16:04:38 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Thu Jun 4 16:04:44 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list Message-ID: You must see for believe http://190.193.182.93:9090/cuiki User: visita Pass: nothing here Still needs a lot of work , but Edgar @morplenauta en twitter From brasspen at gmail.com Thu Jun 4 16:13:43 2015 From: brasspen at gmail.com (Chris Cunnington) Date: Thu Jun 4 16:13:51 2015 Subject: [squeak-dev] A Cuis/GreenNeon website online Message-ID: I?ve got a few old GreenNeon websites in the closet. I?ve loaded into Cuis. [1] I?ve attached the image. [2] I?ll probably do another one next week. I?d say this the first ever Cuis website, but I think Edgar just beat me to that. FWIW, Chris [1] http://136.243.33.94:8675 [2] https://www.dropbox.com/s/75aca9e1b7w9ciq/OSRConCuis.zip?dl=0 -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/a04e44ab/attachment.htm From karlramberg at gmail.com Thu Jun 4 16:23:54 2015 From: karlramberg at gmail.com (karl ramberg) Date: Thu Jun 4 16:23:59 2015 Subject: [squeak-dev] XMLTokenizer problem with ampersand In-Reply-To: References: Message-ID: Hi, I tested three different HTML parsers and found SOUP to work best for my needs. Thank you all. Karl On Tue, Jun 2, 2015 at 6:17 PM, Chris Muller wrote: > On Mon, Jun 1, 2015 at 9:10 PM, Levente Uzonyi wrote: > > XMLTokenizer is not suitable to parse HTML documents. XML and HTML may > look > > similar, but are very different. > > We used to use Soup[1] to parse HTML pages. > > Have you used Todd Blanchard's "HTML & CSS Validating Parser" [1], if > so how does it compare to Soup? > > [1] -- http://www.squeaksource.com/htmlcssparser.html > > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/6e270a39/attachment.htm From garduino at gmail.com Thu Jun 4 16:35:20 2015 From: garduino at gmail.com (=?UTF-8?Q?Germ=C3=A1n_Arduino?=) Date: Thu Jun 4 16:35:22 2015 Subject: [squeak-dev] A Cuis/GreenNeon website online In-Reply-To: References: Message-ID: Excellent! Thanks for sharing! 2015-06-04 13:13 GMT-03:00 Chris Cunnington : > I?ve got a few old GreenNeon websites in the closet. I?ve loaded into > Cuis. [1] > I?ve attached the image. [2] I?ll probably do another one next week. > > I?d say this the first ever Cuis website, but I think Edgar just beat me > to that. > > FWIW, > Chris > > > [1] http://136.243.33.94:8675 > > [2] https://www.dropbox.com/s/75aca9e1b7w9ciq/OSRConCuis.zip?dl=0 > > > > -- Saludos / Regards, Germ?n Arduino www.arduinosoftware.com -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/282ba881/attachment.htm From garduino at gmail.com Thu Jun 4 16:45:34 2015 From: garduino at gmail.com (=?UTF-8?Q?Germ=C3=A1n_Arduino?=) Date: Thu Jun 4 16:45:36 2015 Subject: [squeak-dev] Re: [squeakRos] [OT] Dedicated to Chris and all people on Squeak,SqueakRos and Cuis list In-Reply-To: References: Message-ID: This is a Cuis image? 2015-06-04 13:04 GMT-03:00 'Edgar J. De Cleene' edgardec2005@gmail.com [squeakRos] : > > > You must see for believe > http://190.193.182.93:9090/cuiki > User: visita > Pass: nothing here > > Still needs a lot of work , but > > Edgar > @morplenauta en twitter > > __._,_.___ > ------------------------------ > Enviado por: "Edgar J. De Cleene" > ------------------------------ > Responder mediante la Web > > ? Responder a remitente > > ? Responder a grupo > > ? Crear un tema nuevo > > ? Mensajes con este tema > > (1) > correo electr??nico a: squeakRos-unsubscribe@gruposyahoo.com.ar > Visita tu grupo > > > > [image: Yahoo! Grupos] > > ? Privacidad > ? Cancelar suscripci? ??n > > ? Condiciones de uso > > . > > __,_._,___ > -- Saludos / Regards, Germ?n Arduino www.arduinosoftware.com -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/a6306e7a/attachment-0001.htm From karlramberg at gmail.com Thu Jun 4 19:39:20 2015 From: karlramberg at gmail.com (karl ramberg) Date: Thu Jun 4 19:39:22 2015 Subject: [squeak-dev] Bitmap DejaVu sans punktuation mark sizes In-Reply-To: References: <2652CAC8-D94A-4961-92BE-56AB57AE7DC8@freudenbergs.de> Message-ID: Yes, pixels in the retina type displays are truly tiny. Pixels seem likely to become invisible by them self, kind of like an atom. Gezira and Nile seem like a interesting display solution. I have not had any success compiling it for Windows though, so I have not been able to use it. Karl On Thu, Jun 4, 2015 at 12:51 AM, tim Rowledge wrote: > > On 03-06-2015, at 3:11 PM, karl ramberg wrote: > > > A fix for this would be great. > > My eye are getting worse by the day it feels like. > > Welcome to over-30-land. This is another reason we really ought to try to > move away from predominantly pixel based graphics to vector based - scaling > to suit the user needs works so much better. We have had the basic > capability for at least a decade (remember ?pooh??) and now there is Nile > to add to the mix. > > > tim > -- > tim Rowledge; tim@rowledge.org; http://www.rowledge.org/tim > Useful random insult:- He has a tenuous grip on the obvious. > > > > -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/fcd05366/attachment.htm From edgardec2005 at gmail.com Thu Jun 4 20:55:11 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Thu Jun 4 20:55:21 2015 Subject: [squeak-dev] A Cuis/GreenNeon website online In-Reply-To: Message-ID: On 6/4/15, 1:13 PM, "Chris Cunnington" wrote: > I?ve got a few old GreenNeon websites in the closet. I?ve loaded into Cuis. > [1] > I?ve attached the image. [2] I?ll probably do another one next week. > > I?d say this the first ever Cuis website, but I think Edgar just beat me to > that. > > FWIW, > Chris Ja. Nope as still is Squeak and Kom + HV2. The image also have OMeta loaded for future experiments on Smalltalk to HTML5 Canvas By the way , running your example and trying to have a debug mode as Kom have , found ORSCon ask for some like imagen/bg/x where x was some .gif and .png I create the folders and pun any .gif and .png with same name as ORSCon ask At this point have complaints about Seaside Canvas do not could render . Today when I wish put the World (notice each times you access the site the Trancrispt changes), have the following method grabaFoto ^ (Form fromDisplay: (0 @ 0 corner: 1250 @ 100)) asWebImage Also fail. And world ^ World imageForm Do not fail Wish join forces and have a real Cuis enhanced wiki ? We could use ?Cuiki? as name. Cheers. Edgar @morplenauta en twitter -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/0aac3695/attachment.htm From eliot.miranda at gmail.com Thu Jun 4 21:00:56 2015 From: eliot.miranda at gmail.com (Eliot Miranda) Date: Thu Jun 4 21:00:59 2015 Subject: [squeak-dev] New CogVMs available Message-ID: ... at http://www.mirandabanda.org/files/Cog/VM/VM.r3370 CogVM source as per VMMaker.oscog-eem.1339/r3370 Spur Cogit: Since the invariant is that the receiver is never forwarded, Spur must check for forwarding on block activation. A become between closure creation and closure evaluation can forward the receiver, and it must be unforwarded. Here we do so by checking for a forwarded receiver in the value[:] primitives. This is a major blow to block performance; e.g. the nfib block b := [:n| n <= 1 ifTrue: [1] ifFalse: [1 + (b value: n - 1) + (b value: n - 2)]]. slows down by 11%. So we can and will do better. We should scan for receiver usage in the JIT and optionally compile unforwarding code in the prolog depending on whether self is used or not. Fix Spur block performance now that we follow forwarded receivers in blocks; see VMMaker.oscog-eem.1334. Scan blocks for inst var usage, only unforwarding in the prologue of blocks that actually refer to inst vars. In a test Spur Squeak image only 12.5% of blocks do refer to inst vars. So this is definitely a win. Add a special purpose store check trampoline to store check the updated receiver. Make sure it's only called if the eceiuver is updated. Add state to CogBytecodeDescriptor, CogBlockStart and CogBlockMethod to track block inst var usage. Sista: Fix the bug where rcvrReg was nil in genEqualsEqualsnoBranch. Generic Cogit: Use the Tst-based generators for immediate and SmallInteger tests more widely to save a few more instructions. Fix the hack introduced in VMMaker.oscog-eem.1199 for Sista which merely stopped reclaiming closed PICs. In non-Sista VMs do the usual thing of decaying usage counts on PICs, as with methods, and reclaiming those least used. In Sista, retain PICs until the next cycle, identifying unused PICs as part of the compaction scan, reminiscent of tri-colour incremental GC. Move defaultCogCodeSize into the CogAbstractInstruction hierarchy so that e.g. CogARMCompiler can specify a larger default code zone. Newspeak Cogit: Fix assert-fails with absent receiver sends in Newspeak. Have the implicit and outer send lookup trampolines set the stacked receiver (when there is one) when setting the implciit receiver. Streamline send trampoline creation by refactoring trampoline name generation so that the two limits, NumSendTrampolines - 2 and numRegArgs are treated separately, and numArgsOrSendNumArgsReg: answers the relevant numArgs argument. This should clear up confusion between numRegArgs (which can be 0, 1 & 2) and NumSendTrampolines - 2, which is always 2. linux builds: Fix VERSION_TAG format to agree with existing convention. -- best, Eliot -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/3ca5d13a/attachment.htm From edgardec2005 at gmail.com Thu Jun 4 21:16:51 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Thu Jun 4 21:16:59 2015 Subject: [squeak-dev] Re: [squeakRos] [OT] Dedicated to Chris and all people on Squeak,SqueakRos and Cuis list In-Reply-To: Message-ID: On 6/4/15, 1:45 PM, "Germ?n Arduino" wrote: > This is a Cuis image? > > 2015-06-04 13:04 GMT-03:00 'Edgar J. De Cleene' edgardec2005@gmail.com > [squeakRos] : >> >> ? >> >> >> >> >> You must see for believe >> http://190.193.182.93:9090/cuiki >> User: visita >> Pass: nothing here >> >> Still needs a lot of work , but >> >> Edgar >> @morplenauta en twitter > > > No, it?s SqueakRosCore4dot5. > And have Kom + HV2 + OMeta + lot of external folders > The cuiki example uses > > cuiki > | path sorted | > self class externalFolder: 'cuiki'. > path _ FileDirectory default pathName. > self page: nil. > self pageAdd: (StandardFileStream readOnlyFileNamed: path , '/cuiki > /cuiki.html') contents. > sorted := self sortDates: #blog. > sorted > do: [:aMiHTMLData | self cuikiPost: aMiHTMLData]. > > ^self pageEnd. > > Needs a lot of polish, but you have the idea. > As I said, reading HTML5 Canvas of Fulton (O?Reily). > > I need > > Normalize all blogs to UTF8 > Remove formatting by tinymce for have only strings > So I could render a short version of the infamous SqueakLightChronicles coming > from Sblog,Pier,Aida, etc > > You should see the first three lines and expand if you wish > Some ?Cr?nicas? work now, > > Y aca neste Bar hablamo Rosarino Basico hablamo. > > Rosarino Basico is to Spanish as Pharo is to Smalltalk 80 > > > Chees -------------- next part -------------- An HTML attachment was scrubbed... URL: http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150604/2014820c/attachment.htm From commits at source.squeak.org Thu Jun 4 21:55:05 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Thu Jun 4 21:55:07 2015 Subject: [squeak-dev] Daily Commit Log Message-ID: <20150604215505.775.qmail@box4.squeakfoundation.org> Changes to Trunk (http://source.squeak.org/trunk.html) in the last 24 hours: http://lists.squeakfoundation.org/pipermail/packages/2015-June/008742.html Name: HelpSystem-Core-kfr.75 Ancestors: HelpSystem-Core-mt.74 HelpBrowser>>accept: changed so it works. The changed topic is compiled but the current topic loaded in the HelpBrowser is not updated ============================================= http://lists.squeakfoundation.org/pipermail/packages/2015-June/008743.html Name: HelpSystem-Core-kfr.76 Ancestors: HelpSystem-Core-kfr.75 Added a check/ bail out for non editable help topics ============================================= http://lists.squeakfoundation.org/pipermail/packages/2015-June/008744.html Name: HelpSystem-Core-kfr.77 Ancestors: HelpSystem-Core-kfr.76 Replace a edited help topic in HelpBrowser with a new one. There is still a bug that the updated topic changes place in the topic list I'm also a little confused why there is two hierachies with the help topics in rootTopic and topLevelTopics ============================================= http://lists.squeakfoundation.org/pipermail/packages/2015-June/008745.html Name: HelpSystem-Core-mt.78 Ancestors: HelpSystem-Core-kfr.77 Class-based help topics are editable again. Help browser updates correctly after edits. ============================================= From pbpublist at gmail.com Thu Jun 4 22:50:42 2015 From: pbpublist at gmail.com (Phil (list)) Date: Thu Jun 4 22:50:18 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: References: Message-ID: <1433458242.4957.18.camel@gmail.com> On Thu, 2015-06-04 at 13:04 -0300, Edgar J. De Cleene wrote: > You must see for believe > http://190.193.182.93:9090/cuiki > User: visita > Pass: nothing here > > > Still needs a lot of work , but > I can't login in with that login info (the authentication dialog keeps coming back up) > > Edgar > @morplenauta en twitter > > > > From jgr.asselin at me.com Thu Jun 4 23:43:04 2015 From: jgr.asselin at me.com (Raymond Asselin) Date: Thu Jun 4 23:43:09 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: <1433458242.4957.18.camel@gmail.com> References: <1433458242.4957.18.camel@gmail.com> Message-ID: <5C27472B-9FC8-41D6-A28B-A149470B0F0F@me.com> Edgar is a Man who like kidding! There is nothing to put on de password side. Envoy? de mon iPhone > Le 2015-06-04 ? 18:50, Phil (list) a ?crit : > >> On Thu, 2015-06-04 at 13:04 -0300, Edgar J. De Cleene wrote: >> You must see for believe >> http://190.193.182.93:9090/cuiki >> User: visita >> Pass: nothing here >> >> >> Still needs a lot of work , but > > I can't login in with that login info (the authentication dialog keeps > coming back up) > >> >> Edgar >> @morplenauta en twitter > > > From pbpublist at gmail.com Fri Jun 5 01:10:57 2015 From: pbpublist at gmail.com (Phil (list)) Date: Fri Jun 5 01:10:33 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: <5C27472B-9FC8-41D6-A28B-A149470B0F0F@me.com> References: <1433458242.4957.18.camel@gmail.com> <5C27472B-9FC8-41D6-A28B-A149470B0F0F@me.com> Message-ID: <1433466657.2720.0.camel@gmail.com> On Thu, 2015-06-04 at 19:43 -0400, Raymond Asselin wrote: > Edgar is a Man who like kidding! > There is nothing to put on de password side. > Heh... that would explain it. From lewis at mail.msen.com Fri Jun 5 01:37:07 2015 From: lewis at mail.msen.com (David T. Lewis) Date: Fri Jun 5 01:37:11 2015 Subject: [squeak-dev] vmrun script Message-ID: <20150605013707.GA90648@shell.msen.com> I am in the habit of installing several VMs on my Linux computer, and running images of various vintages and image formats. Here is the script that I use to run an appropriate VM for any given image. I install the script as /usr/local/bin//vmrun and use it like this: $ vmrun whatever.image & Dave -------------- next part -------------- #!/bin/sh # dtl Wed May 20 19:49:25 EDT 2015 # # vmrun utility script # # Select a VM and run an image based on the image format number # # Assume that /usr/local/bin/squeak runs the traditional VM for 32-bit # and 64-bit images in the traditional image formats. Assume that # /usr/local/bin/cog runs Cog, /usr/local/bin/spur runs the VM for 32-bit # Spur images, and /usr/local/bin/spur64 runs the VM for 64-bit Spur # images. # # Use ckformat to determine image requirements. See package ImageFormat # in the SqueakSource VMMaker repository. The executable is distributed # with the standard interpreter VM. To generate C source for the ckformat # utility, evaluate: # "ImageFormat createCkStatusProgram" # # VMs look for this default name if an image has not been # specified. Use the same default for this script. DEFAULT_IMAGENAME="squeak.image" # Scripts for running various interpreters INTERP_SCRIPT="squeak" # Context VM for 32 and 64 bit images COG_SCRIPT="cog" # Cog VM SPUR_SCRIPT="spur" # Spur VM for 32-bit Spur image SPUR64_SCRIPT="spur64" # Spur VM for 64-bit Spur image # Assume scripts are in the same directory, e.g. /usr/local/bin BIN=`dirname "$0"` # The ckformat utility is distributed with interpreter VM builds. # Find it in the lib directory for the interpreter VM. CKFORMAT=`squeak -version | grep 'plugin path' | sed 's/^.*default: //' | sed 's/]$//'`ckformat # Paths to the run scripts INTERP="$BIN/$INTERP_SCRIPT" # Context interpreter VM COG="$BIN/$COG_SCRIPT" # Cog VM for 32-bit images with closure support SPUR="$BIN/$SPUR_SCRIPT" # Spur VM for Spur 32-bit image format 6521 SPUR64="$BIN/$SPUR64_SCRIPT" # Spur VM for Spur 64-bit image format 68109 for arg in $* do case ${arg} in -*) #ignore ;; *) # either and option argument or the image name if test -f ${arg} then NUM=`${CKFORMAT} ${arg} 2>/dev/null` if test $? -eq 0 then IMAGENAME=${arg} break fi else if test -f ${arg}.image then NUM=`${CKFORMAT} ${arg}.image 2>/dev/null` if test $? -eq 0 then IMAGENAME=${arg}.image break fi fi fi ;; esac done # if no image name specified on command line, try the default if test ! ${IMAGENAME} then if test -f ${DEFAULT_IMAGENAME} then IMAGENAME=${DEFAULT_IMAGENAME} NUM=`${CKFORMAT} ${IMAGENAME} 2>/dev/null` if test $? -ne 0 then echo image format ${NUM} not recognized for ${IMAGENAME} exit 1 fi else echo `basename $0` $@: image file not found exit 1 fi fi case $NUM in 6502) VM=$INTERP ;; 6504 | 6505) VM=$COG ;; 6521) VM=$SPUR ;; 68000 | 68002 | 68003) VM=$INTERP ;; 68019) VM=$SPUR64 ;; *) echo image format ${NUM} not recognized for ${IMAGENAME} exit -1;; esac # Use standard VM as default if preferred VM not present if test ! -x ${VM} then echo ${VM} not found, using ${INTERP} VM="${INTERP}" fi ### echo running ${IMAGENAME} with image format $NUM using $VM exec ${VM} $@ From asqueaker at gmail.com Fri Jun 5 01:54:12 2015 From: asqueaker at gmail.com (Chris Muller) Date: Fri Jun 5 01:54:14 2015 Subject: [squeak-dev] vmrun script In-Reply-To: <20150605013707.GA90648@shell.msen.com> References: <20150605013707.GA90648@shell.msen.com> Message-ID: Yes!!! Thank you thank you Dave!! We should include this with the release if it works. :) On Thu, Jun 4, 2015 at 8:37 PM, David T. Lewis wrote: > I am in the habit of installing several VMs on my Linux computer, and > running images of various vintages and image formats. Here is the script > that I use to run an appropriate VM for any given image. > > I install the script as /usr/local/bin//vmrun and use it like this: > > $ vmrun whatever.image & > > Dave > > > > From asqueaker at gmail.com Fri Jun 5 02:12:24 2015 From: asqueaker at gmail.com (Chris Muller) Date: Fri Jun 5 02:12:26 2015 Subject: [squeak-dev] vmrun script In-Reply-To: <20150605013707.GA90648@shell.msen.com> References: <20150605013707.GA90648@shell.msen.com> Message-ID: Do you have a decent vm upgrade script? When Eliot releases a new vm how do you upgrade? On Thu, Jun 4, 2015 at 8:37 PM, David T. Lewis wrote: > I am in the habit of installing several VMs on my Linux computer, and > running images of various vintages and image formats. Here is the script > that I use to run an appropriate VM for any given image. > > I install the script as /usr/local/bin//vmrun and use it like this: > > $ vmrun whatever.image & > > Dave > > > > From Das.Linux at gmx.de Fri Jun 5 05:13:05 2015 From: Das.Linux at gmx.de (Tobias Pape) Date: Fri Jun 5 05:13:10 2015 Subject: [squeak-dev] Re: [Pharo-dev] New CogVMs available In-Reply-To: References: Message-ID: <83B2376B-7411-4C18-BE92-70D0E946EEA8@gmx.de> And updated on ci. On 04.06.2015, at 23:00, Eliot Miranda wrote: > ... at http://www.mirandabanda.org/files/Cog/VM/VM.r3370 > > CogVM source as per VMMaker.oscog-eem.1339/r3370 > > Spur Cogit: > Since the invariant is that the receiver is never forwarded, Spur must check for > forwarding on block activation. A become between closure creation and closure > evaluation can forward the receiver, and it must be unforwarded. Here we do so > by checking for a forwarded receiver in the value[:] primitives. This is a > major blow to block performance; e.g. the nfib block > b := [:n| n <= 1 > ifTrue: [1] > ifFalse: [1 + (b value: n - 1) + (b value: n - 2)]]. > slows down by 11%. So we can and will do better. We should scan for receiver > usage in the JIT and optionally compile unforwarding code in the prolog > depending on whether self is used or not. > > Fix Spur block performance now that we follow forwarded receivers in blocks; see > VMMaker.oscog-eem.1334. Scan blocks for inst var usage, only unforwarding in > the prologue of blocks that actually refer to inst vars. In a test Spur Squeak > image only 12.5% of blocks do refer to inst vars. So this is definitely a win. > > Add a special purpose store check trampoline to store check the updated > receiver. Make sure it's only called if the eceiuver is updated. > > Add state to CogBytecodeDescriptor, CogBlockStart > and CogBlockMethod to track block inst var usage. > > Sista: > Fix the bug where rcvrReg was nil in genEqualsEqualsnoBranch. > > Generic Cogit: > Use the Tst-based generators for immediate and SmallInteger tests more widely > to save a few more instructions. > > Fix the hack introduced in VMMaker.oscog-eem.1199 for Sista which merely stopped > reclaiming closed PICs. In non-Sista VMs do the usual thing of decaying usage > counts on PICs, as with methods, and reclaiming those least used. In Sista, > retain PICs until the next cycle, identifying unused PICs as part of the > compaction scan, reminiscent of tri-colour incremental GC. > > Move defaultCogCodeSize into the CogAbstractInstruction hierarchy so that > e.g. CogARMCompiler can specify a larger default code zone. > > Newspeak Cogit: > Fix assert-fails with absent receiver sends in Newspeak. Have the implicit > and outer send lookup trampolines set the stacked receiver (when there is one) > when setting the implciit receiver. > > Streamline send trampoline creation by refactoring trampoline name generation > so that the two limits, NumSendTrampolines - 2 and numRegArgs are treated > separately, and numArgsOrSendNumArgsReg: answers the relevant numArgs argument. > This should clear up confusion between numRegArgs (which can be 0, 1 & 2) and > NumSendTrampolines - 2, which is always 2. > > linux builds: > Fix VERSION_TAG format to agree with existing convention. > -- > best, > Eliot From edgardec2005 at gmail.com Fri Jun 5 08:29:49 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Fri Jun 5 08:30:01 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: <1433458242.4957.18.camel@gmail.com> Message-ID: On 6/4/15, 7:50 PM, "Phil (list)" wrote: > On Thu, 2015-06-04 at 13:04 -0300, Edgar J. De Cleene wrote: >> You must see for believe >> http://190.193.182.93:9090/cuiki >> User: visita >> Pass: nothing here >> >> >> Still needs a lot of work , but >> > > I can't login in with that login info (the authentication dialog keeps > coming back up) > >> >> Edgar >> @morplenauta en twitter >> >> >> >> It's working..... -------------- next part -------------- A non-text attachment was scrubbed... Name: cuikilg.jpg Type: image/jpeg Size: 29905 bytes Desc: not available Url : http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20150605/29b148e6/cuikilg-0001.jpg From edgardec2005 at gmail.com Fri Jun 5 08:54:51 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Fri Jun 5 08:55:07 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: <5C27472B-9FC8-41D6-A28B-A149470B0F0F@me.com> Message-ID: On 6/4/15, 8:43 PM, "Raymond Asselin" wrote: > Edgar is a Man who like kidding! > There is nothing to put on de password side. > > Envoy? de mon iPhone > >> Le 2015-06-04 ? 18:50, Phil (list) a ?crit : >> >>> On Thu, 2015-06-04 at 13:04 -0300, Edgar J. De Cleene wrote: >>> You must see for believe >>> http://190.193.182.93:9090/cuiki >>> User: visita >>> Pass: nothing here >>> >>> >>> Still needs a lot of work , but >> >> I can't login in with that login info (the authentication dialog keeps >> coming back up) >> >>> >>> Edgar >>> @morplenauta en twitter >> Kudos. I should write no password or let the password blank. And for kidding, I wish my English was good enough for doing the SqueakLightChronicles in English. The story begins with SqueakLight and the amazing SBlog people. At the time use for take notes for myself in humour style. Then I use Pharo with Pier and MinimalMorphic with Aida. Some time ago with my Squeak forks, the last in use is SqueakRosCore4dot5. Inside the system I have. Complete Squeak swiki. Technical notes for myself. SqueakLightChronicles , things what happening around. Experimental Web 2.0 with all kind of external GitHub projects. Without Node,js, NPM, Bower, Angular, Meteor, React or tons of things you put in the machine for render HTML5. Consecuences ? Mi iMac refuse to run any Pharo,Cuis or Squeak Web in Yosemite. But same .image runs if I boot of external disk with Snow Leopard and in another Mac Yosemite where I never run the original GitHub project for see how I made same without JavaScript ecosystem Explore it with /news, should see last Squeak Swiki and any I touch the last week /sysCom should list commands the system understand. Consider all a giant sandbox in continuos change. Regards From edgardec2005 at gmail.com Fri Jun 5 09:04:20 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Fri Jun 5 09:04:33 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: <1433466657.2720.0.camel@gmail.com> Message-ID: On 6/4/15, 10:10 PM, "Phil (list)" wrote: > On Thu, 2015-06-04 at 19:43 -0400, Raymond Asselin wrote: >> Edgar is a Man who like kidding! I was so serious as Buster Keaton >> There is nothing to put on de password side. >> > > Heh... that would explain it. I forget thank you for OMeta in Cuis and for the Lisp example. OMeta and Xtreams also was in the running .image. Edgar From pbpublist at gmail.com Fri Jun 5 09:13:37 2015 From: pbpublist at gmail.com (Phil (list)) Date: Fri Jun 5 09:13:13 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: References: Message-ID: <1433495617.2720.1.camel@gmail.com> On Fri, 2015-06-05 at 05:29 -0300, Edgar J. De Cleene wrote: > On 6/4/15, 7:50 PM, "Phil (list)" wrote: > > > On Thu, 2015-06-04 at 13:04 -0300, Edgar J. De Cleene wrote: > >> You must see for believe > >> http://190.193.182.93:9090/cuiki > >> User: visita > >> Pass: nothing here > >> > >> > >> Still needs a lot of work , but > >> > > > > I can't login in with that login info (the authentication dialog keeps > > coming back up) > > > >> > >> Edgar > >> @morplenauta en twitter > >> > >> > >> > >> > It's working..... > When I stopped putting 'nothing here' in for the password, it works for me too :-) From pbpublist at gmail.com Fri Jun 5 09:17:11 2015 From: pbpublist at gmail.com (Phil (list)) Date: Fri Jun 5 09:16:47 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: References: Message-ID: <1433495831.2720.4.camel@gmail.com> On Fri, 2015-06-05 at 06:04 -0300, Edgar J. De Cleene wrote: > > > On 6/4/15, 10:10 PM, "Phil (list)" wrote: > > > On Thu, 2015-06-04 at 19:43 -0400, Raymond Asselin wrote: > >> Edgar is a Man who like kidding! > > I was so serious as Buster Keaton > > >> There is nothing to put on de password side. > >> > > > > Heh... that would explain it. > > I forget thank you for OMeta in Cuis and for the Lisp example. > OMeta and Xtreams also was in the running .image. > You are very welcome and I hope you find OMeta as useful as I do. FYI, I'm also looking into improving the debugging and/or adding tracing support at some point. > Edgar > > > From edgardec2005 at gmail.com Fri Jun 5 09:24:20 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Fri Jun 5 09:24:29 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: <1433495617.2720.1.camel@gmail.com> Message-ID: El 6/5/15, 6:13 AM, "Phil (list)" escribi?: >When I stopped putting 'nothing here' in for the password, it works for >me too :-) Sorry if the G4 hangs. Many changes from previous versions, I need clean up. The Squeak wiki do not let delete pages and do not have ?author? My version have titles of ?pages? as index and a conversion work around for original page numbers . Which just discover is failing now? But fixing rescuing DivagacionesIndex pageNumbers from older versions From edgardec2005 at gmail.com Fri Jun 5 09:33:43 2015 From: edgardec2005 at gmail.com (Edgar J. De Cleene) Date: Fri Jun 5 09:33:52 2015 Subject: [squeak-dev] [OT] Dedicated to Chris and all people on Squeak, SqueakRos and Cuis list In-Reply-To: <1433495831.2720.4.camel@gmail.com> Message-ID: El 6/5/15, 6:17 AM, "Phil (list)" escribi?: >You are very welcome and I hope you find OMeta as useful as I do. FYI, >I'm also looking into improving the debugging and/or adding tracing >support at some point. You must see DebugReport in SqueakMap. Here the working link http://squeak.sakura.ne.jp/etc/DebugReportSample/ From commits at source.squeak.org Fri Jun 5 20:05:15 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:05:16 2015 Subject: [squeak-dev] Squeak 4.6: 39Deprecated-ar.19.mcz Message-ID: Chris Muller uploaded a new version of 39Deprecated to project Squeak 4.6: http://source.squeak.org/squeak46/39Deprecated-ar.19.mcz ==================== Summary ==================== Name: 39Deprecated-ar.19 Author: ar Time: 5 March 2010, 9:44:11.754 pm UUID: 8da20c38-7d28-3241-9f29-da261d6f9bfe Ancestors: 39Deprecated-dtl.18 Clean up after Smalltalk/SystemDictionary refactoring. ==================== Snapshot ==================== ----- Method: ContextPart>>methodSelector (in category '*39Deprecated') ----- methodSelector "Answer the selector of the method that created the receiver." self deprecated: 'use #selector'. ^self selector. ! ----- Method: SharedQueue2>>flush (in category '*39Deprecated') ----- flush self deprecated: 'use removeAll'. ^self removeAll! ----- Method: SharedQueue2>>flushAllSuchThat: (in category '*39Deprecated') ----- flushAllSuchThat: aBlock self deprecated: 'use removeAllSuchThat:'. ^self removeAllSuchThat: aBlock! From asqueaker at gmail.com Fri Jun 5 20:07:27 2015 From: asqueaker at gmail.com (Chris Muller) Date: Fri Jun 5 20:07:32 2015 Subject: [squeak-dev] build.squeak.org down Message-ID: Service Temporarily Unavailable From commits at source.squeak.org Fri Jun 5 20:12:25 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:12:28 2015 Subject: [squeak-dev] Squeak 4.6: PreferenceBrowser-mt.53.mcz Message-ID: Chris Muller uploaded a new version of PreferenceBrowser to project Squeak 4.6: http://source.squeak.org/squeak46/PreferenceBrowser-mt.53.mcz ==================== Summary ==================== Name: PreferenceBrowser-mt.53 Author: mt Time: 25 April 2015, 10:13:23.176 am UUID: 91503306-d9bf-2a45-a7b5-faec6044b5ee Ancestors: PreferenceBrowser-mt.52 Fixed height in search field. (Note: We have to refactor that code to tool builder...) ==================== Snapshot ==================== SystemOrganization addCategory: #PreferenceBrowser! (PackageInfo named: 'PreferenceBrowser') postscript: 'Preferences removePreference: #syntaxHighlightingAsYouType. Preferences removePreference: #syntaxHighlightingAsYouTypeLeftArrowAssignment. Preferences removePreference: #syntaxHighlightingAsYouTypeAnsiAssignment.'! SystemWindow subclass: #PreferenceBrowserMorph instanceVariableNames: 'mainPanel defaultButton saveButton loadButton saveToDiskButton loadFromDiskButton themeButton helpButton preferenceList lastKeystrokeTime lastKeystrokes highlightedPreferenceButton' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PreferenceBrowserMorph class>>withModel: (in category 'instance creation') ----- withModel: aPreferenceBrowser ^self new initializeWithModel: aPreferenceBrowser; yourself.! ----- Method: PreferenceBrowserMorph>>adjustPreferenceListItemsWidth (in category 'updating') ----- adjustPreferenceListItemsWidth | panel | self preferenceList scroller submorphs ifEmpty: [^self]. panel := self preferenceListInnerPanel. panel width: self preferenceList width - (self preferenceList scrollBarThickness*2). panel submorphsDo: [:ea | ea hResizing: #rigid; width: panel width]. self preferenceList setScrollDeltas.! ----- Method: PreferenceBrowserMorph>>basicButton (in category 'submorphs - buttons') ----- basicButton | button | button := SimpleButtonMorph new. button borderWidth: 2; borderColor: #raised; on: #mouseEnter send: #value to: [button borderColor: self paneColor]; on: #mouseLeave send: #value to: [button borderColor: #raised]; vResizing: #spaceFill; useRoundedCorners; clipSubmorphs: true; color: self paneColor muchLighter; target: self model. ^button! ----- Method: PreferenceBrowserMorph>>basicKeyPressed: (in category 'event handling') ----- basicKeyPressed: anEvent | aChar oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionPref | aChar := anEvent keyCharacter. nextSelection := oldSelection := self selectedPreferenceIndex. max := self selectedCategoryPreferences size. 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 selectedCategoryPreferences copyFrom: oldSelection + 1 to: max). nextSelectionList addAll: (self selectedCategoryPreferences copyFrom: 1 to: oldSelection). "Get rid of blanks and style used in some lists" nextSelectionPref := nextSelectionList detect: [:a | a name withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] ifNone: [^ self preferenceList flash"match not found"]. nextSelection := self selectedCategoryPreferences findFirst: [:a | a = nextSelectionPref]. "No change if model is locked" oldSelection == nextSelection ifTrue: [^ self preferenceList flash]. ^ self selectedPreferenceIndex: nextSelection! ----- Method: PreferenceBrowserMorph>>buttonRowLayoutFrame (in category 'submorphs - buttons') ----- buttonRowLayoutFrame ^LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (TextStyle defaultFont height * 2.5))! ----- Method: PreferenceBrowserMorph>>defaultButton (in category 'submorphs - buttons') ----- defaultButton ^defaultButton ifNil: [defaultButton := self basicButton label: 'default' translated; actionSelector: #defaultSelected; setBalloonText: 'Click here to reset all the preferences to their standard ', 'default values.' translated]! ----- Method: PreferenceBrowserMorph>>downKeyPressed: (in category 'event handling') ----- downKeyPressed: anEvent self selectedPreferenceIndex: (self selectedPreferenceIndex + 1 min: self selectedCategoryPreferences size)! ----- Method: PreferenceBrowserMorph>>endKeyPressed: (in category 'event handling') ----- endKeyPressed: anEvent self selectedPreferenceIndex: self selectedCategoryPreferences size. ! ----- Method: PreferenceBrowserMorph>>extent: (in category 'geometry') ----- extent: aPoint super extent: aPoint. self fullBounds. self adjustPreferenceListItemsWidth.! ----- Method: PreferenceBrowserMorph>>helpButton (in category 'submorphs - buttons') ----- helpButton ^helpButton ifNil: [helpButton := self basicButton label: 'help' translated; setBalloonText: 'Click here to get some hints on use of this Preferences ', 'Panel' translated; actionSelector: #helpSelected]! ----- Method: PreferenceBrowserMorph>>homeKeyPressed: (in category 'event handling') ----- homeKeyPressed: anEvent self selectedPreferenceIndex: 1. ! ----- Method: PreferenceBrowserMorph>>initializeWithModel: (in category 'initialization') ----- initializeWithModel: aPreferenceBrowser lastKeystrokeTime := 0. lastKeystrokes := ''. self model: aPreferenceBrowser; setLabel: self model windowTitle; name: 'PreferenceBrowser'; addMorph: self rootPanel fullFrame: self rootPanelLayoutFrame; addMorph: self newButtonRow fullFrame: self buttonRowLayoutFrame.! ----- Method: PreferenceBrowserMorph>>keyPressed: (in category 'event handling') ----- keyPressed: anEvent self selectedCategory ifNil: [^self]. anEvent keyValue = 30 ifTrue: [^self upKeyPressed: anEvent]. anEvent keyValue = 31 ifTrue: [^self downKeyPressed: anEvent]. anEvent keyValue = 1 ifTrue: [^self homeKeyPressed: anEvent]. anEvent keyValue = 4 ifTrue: [^self endKeyPressed: anEvent]. anEvent keyValue = 11 ifTrue: [^self pageUpKeyPressed: anEvent]. anEvent keyValue = 12 ifTrue: [^self pageDownKeyPressed: anEvent]. self basicKeyPressed: anEvent.! ----- Method: PreferenceBrowserMorph>>loadButton (in category 'submorphs - buttons') ----- loadButton ^loadButton ifNil: [loadButton := self basicButton label: 'load' translated; actionSelector: #loadSelected; setBalloonText: 'Click here to reset all the preferences to their values ', 'in your Personal Preferences.' translated]! ----- Method: PreferenceBrowserMorph>>loadFromDiskButton (in category 'submorphs - buttons') ----- loadFromDiskButton ^loadFromDiskButton ifNil: [loadFromDiskButton := self basicButton label: 'load from disk' translated; actionSelector: #loadFromDiskSelected; setBalloonText: 'Click here to load all the preferences from ', 'their saved values on disk.' translated]! ----- Method: PreferenceBrowserMorph>>mainPanel (in category 'submorphs - main panel') ----- mainPanel ^mainPanel ifNil: [mainPanel := BorderedMorph new color: Color transparent; borderWidth: 0; hResizing: #spaceFill; vResizing: #spaceFill; cellInset: 5; changeProportionalLayout; on: #mouseEnter send: #paneTransition: to: self; addMorphBack: self newCategoryList; addMorphBack: self preferenceList; layoutFrame: (LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@ 30 corner: 0@0)); addPaneSplitters; yourself].! ----- Method: PreferenceBrowserMorph>>mouseDownOn:event: (in category 'event handling') ----- mouseDownOn: aPreferenceView event: anEvent anEvent hand newKeyboardFocus: self preferenceList scroller. anEvent yellowButtonPressed ifTrue: [aPreferenceView offerPreferenceNameMenu: self model]! ----- Method: PreferenceBrowserMorph>>newButtonRow (in category 'submorphs - buttons') ----- newButtonRow ^BorderedMorph new color: Color transparent; borderWidth: 0; cellInset: 2; layoutInset: 2; layoutPolicy: TableLayout new; listDirection: #leftToRight; listCentering: #topLeft; cellPositioning: #topLeft; on: #mouseEnter send: #paneTransition: to: self; on: #mouseLeave send: #paneTransition: to: self; addMorphBack: self defaultButton; addMorphBack: self newSeparator; addMorphBack: self saveButton; addMorphBack: self loadButton; addMorphBack: self newSeparator; addMorphBack: self saveToDiskButton; addMorphBack: self loadFromDiskButton; addMorphBack: self newSeparator; addMorphBack: self themeButton; addMorphBack: self newTransparentFiller; addMorphBack: self helpButton; yourself.! ----- Method: PreferenceBrowserMorph>>newCategoryList (in category 'submorphs - category list') ----- newCategoryList ^(PluggableListMorph on: self model list: #categoryList selected: #selectedCategoryIndex changeSelected: #selectedCategoryIndex:) color: Color white; borderInset; hResizing: #spaceFill; vResizing: #spaceFill; layoutFrame: (LayoutFrame fractions: (0@0 corner: 0.25@1)); yourself.! ----- Method: PreferenceBrowserMorph>>newCategoryListPanel (in category 'submorphs - category list') ----- newCategoryListPanel ^Morph new hResizing: #shrinkWrap; vResizing: #spaceFill; color: Color transparent; layoutPolicy: TableLayout new; cellInset: 3; listCentering: #topLeft; listDirection: #topToBottom; cellPositioning: #topLeft; clipSubmorphs: true; addMorphBack: self newCategoryListPanelLabel; addMorphBack: self newCategoryList! ----- Method: PreferenceBrowserMorph>>newCategoryListPanelLabel (in category 'submorphs - category list') ----- newCategoryListPanelLabel ^StringMorph contents: 'Categories' translated.! ----- Method: PreferenceBrowserMorph>>newPreferenceButtonFor: (in category 'submorphs - preference list') ----- newPreferenceButtonFor: aPreference | button | button := PBPreferenceButtonMorph preference: aPreference model: self model. button on: #mouseDown send: #value: to: [:anEvent | self selectedPreference: aPreference; mouseDownOn: button preferenceView event: anEvent]. ^button! ----- Method: PreferenceBrowserMorph>>newPreferenceListInnerPanel (in category 'submorphs - preference list') ----- newPreferenceListInnerPanel | panel maxWidth totalHeight | panel := (Morph new) color: Color transparent; layoutPolicy: TableLayout new; listDirection: #topToBottom; cellPositioning: #topLeft; yourself. self selectedCategoryPreferences do: [:aPref | panel addMorphBack: (self newPreferenceButtonFor: aPref)]. panel submorphs size = 0 ifTrue: [^panel]. maxWidth := (panel submorphs detectMax: [:m | m width]) width. panel width: maxWidth. totalHeight := (panel submorphs collect: [:ea | ea height]) inject: 0 into: [:h :tot | h + tot]. panel height: totalHeight. panel fullBounds. ^panel! ----- Method: PreferenceBrowserMorph>>newPreferenceListPanel (in category 'submorphs - preference list') ----- newPreferenceListPanel | panel | panel := Morph new hResizing: #spaceFill; vResizing: #spaceFill; color: Color transparent; layoutPolicy: TableLayout new; cellInset: 3; listCentering: #topLeft; listDirection: #topToBottom; cellPositioning: #topLeft; clipSubmorphs: true; addMorphBack: self newPreferenceListPanelLabel; addMorphBack: self preferenceList. ^panel.! ----- Method: PreferenceBrowserMorph>>newPreferenceListPanelLabel (in category 'submorphs - preference list') ----- newPreferenceListPanelLabel ^StringMorph contents: 'Preferences' translated.! ----- Method: PreferenceBrowserMorph>>newSearchButton (in category 'submorphs - search panel') ----- newSearchButton ^self basicButton label: 'search' translated; actionSelector: #searchSelected; setBalloonText: 'Type what you want to search for here, then hit ', 'the "Search" button, or else hit RETURN or ENTER' translated.! ----- Method: PreferenceBrowserMorph>>newSearchPanel (in category 'submorphs - search panel') ----- newSearchPanel | bottom | bottom := Morph new color: Color transparent; cellInset: 5; layoutPolicy: TableLayout new; listDirection: #leftToRight; listCentering: #topLeft; cellPositioning: #topLeft; hResizing: #spaceFill; vResizing: #shrinkWrap; addMorphBack: self newSearchTextField yourself. ^Morph new color: Color transparent; layoutPolicy: TableLayout new; listDirection: #topToBottom; listCentering: #topLeft; cellPositioning: #topLeft; hResizing: #spaceFill; vResizing: #shrinkWrap; cellInset: 3; addMorphBack: (StringMorph contents: 'Search preferences for: '); addMorphBack: bottom; yourself.! ----- Method: PreferenceBrowserMorph>>newSearchTextField (in category 'submorphs - search panel') ----- newSearchTextField | ptm | ptm := PluggableTextMorphPlus on: self model text: #searchPatternNeverTriggered accept: #searchPattern:. ptm minimumHeight: 0; balloonText: 'Search preferences ...'; hideScrollBarsIndefinitely; layoutFrame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (TextStyle default lineGrid * 2))); borderInset; color: Color white; vResizing: #spaceFill; hResizing: #spaceFill; acceptOnCR: true; onKeyStrokeSend: #value to: [ ptm hasUnacceptedEdits ifTrue: [ ptm accept ] ]. ^ptm.! ----- Method: PreferenceBrowserMorph>>newSeparator (in category 'submorphs - buttons') ----- newSeparator ^BorderedMorph new borderWidth: 2; borderColor: Color transparent; color: self paneColor; hResizing: #rigid; width: 5; vResizing: #spaceFill; yourself! ----- Method: PreferenceBrowserMorph>>newTransparentFiller (in category 'submorphs - buttons') ----- newTransparentFiller ^Morph new color: Color transparent; vResizing: #spaceFill; hResizing: #spaceFill; yourself.! ----- Method: PreferenceBrowserMorph>>pageDownKeyPressed: (in category 'event handling') ----- pageDownKeyPressed: anEvent self selectedPreferenceIndex: (self selectedPreferenceIndex + self preferencesShowing size min: self selectedCategoryPreferences size). ! ----- Method: PreferenceBrowserMorph>>pageUpKeyPressed: (in category 'event handling') ----- pageUpKeyPressed: anEvent self selectedPreferenceIndex: (self selectedPreferenceIndex - self preferencesShowing size max: 1). ! ----- Method: PreferenceBrowserMorph>>preferenceList (in category 'submorphs - preference list') ----- preferenceList ^preferenceList ifNil: [preferenceList := ScrollPane new color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill; layoutFrame: (LayoutFrame fractions: (0.25@0 corner: 1@1)). preferenceList scroller on: #mouseEnter send: #value: to: [:event | event hand newKeyboardFocus: preferenceList scroller]; on: #keyStroke send: #keyPressed: to: self. preferenceList.]! ----- Method: PreferenceBrowserMorph>>preferenceListInnerPanel (in category 'submorphs - preference list') ----- preferenceListInnerPanel ^self preferenceList scroller submorphs first! ----- Method: PreferenceBrowserMorph>>preferencesShowing (in category 'submorphs - preference list') ----- preferencesShowing | prefs | prefs := self preferenceListInnerPanel submorphs copyFrom: (self selectedPreferenceIndex max: 1) to: self selectedCategoryPreferences size. ^prefs reject: [:ea | (ea top - prefs first top) > self preferenceList scroller height].! ----- Method: PreferenceBrowserMorph>>rootPanel (in category 'submorphs - root panel') ----- rootPanel ^BorderedMorph new color: Color transparent; borderWidth: 0; changeProportionalLayout; addMorphBack: self newSearchTextField; addMorphBack: self mainPanel; yourself.! ----- Method: PreferenceBrowserMorph>>rootPanelLayoutFrame (in category 'submorphs - root panel') ----- rootPanelLayoutFrame | frame | frame := self buttonRowLayoutFrame. ^LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@(frame bottomOffset) corner: 0@0)! ----- Method: PreferenceBrowserMorph>>saveButton (in category 'submorphs - buttons') ----- saveButton ^saveButton ifNil: [saveButton := self basicButton label: 'save' translated; actionSelector: #saveSelected; 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".' translated]! ----- Method: PreferenceBrowserMorph>>saveToDiskButton (in category 'submorphs - buttons') ----- saveToDiskButton ^saveToDiskButton ifNil: [saveToDiskButton := self basicButton label: 'save to disk' translated; actionSelector: #saveToDiskSelected; 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".' translated]! ----- Method: PreferenceBrowserMorph>>selectedCategory (in category 'model access') ----- selectedCategory ^self model selectedCategory! ----- Method: PreferenceBrowserMorph>>selectedCategoryIndex (in category 'model access') ----- selectedCategoryIndex ^self model selectedCategoryIndex! ----- Method: PreferenceBrowserMorph>>selectedCategoryIndex: (in category 'model access') ----- selectedCategoryIndex: anIndex ^self model selectedCategoryIndex: anIndex! ----- Method: PreferenceBrowserMorph>>selectedCategoryPreferences (in category 'model access') ----- selectedCategoryPreferences ^self model selectedCategoryPreferences! ----- Method: PreferenceBrowserMorph>>selectedPreference (in category 'model access') ----- selectedPreference ^self model selectedPreference! ----- Method: PreferenceBrowserMorph>>selectedPreference: (in category 'model access') ----- selectedPreference: aPreference ^self model selectedPreference: aPreference! ----- Method: PreferenceBrowserMorph>>selectedPreferenceButton (in category 'submorphs - preference list') ----- selectedPreferenceButton ^(self preferenceListInnerPanel submorphs at: self selectedPreferenceIndex)! ----- Method: PreferenceBrowserMorph>>selectedPreferenceIndex (in category 'model access') ----- selectedPreferenceIndex ^self model selectedPreferenceIndex! ----- Method: PreferenceBrowserMorph>>selectedPreferenceIndex: (in category 'model access') ----- selectedPreferenceIndex: anIndex ^self model selectedPreferenceIndex: anIndex! ----- Method: PreferenceBrowserMorph>>themeButton (in category 'submorphs - buttons') ----- themeButton ^themeButton ifNil: [themeButton := self basicButton label: 'theme...' translated; actionSelector: #themeSelected; 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].! ----- Method: PreferenceBrowserMorph>>turnOffSelectedPreference (in category 'submorphs - preference list') ----- turnOffSelectedPreference highlightedPreferenceButton ifNil: [^self]. highlightedPreferenceButton highlightOff. highlightedPreferenceButton := nil.! ----- Method: PreferenceBrowserMorph>>turnOnSelectedPreference (in category 'submorphs - preference list') ----- turnOnSelectedPreference highlightedPreferenceButton ifNotNil: [:m | m highlightOff]. highlightedPreferenceButton := self selectedPreferenceButton highlightOn; yourself. self preferenceList scrollToShow: highlightedPreferenceButton bounds.! ----- Method: PreferenceBrowserMorph>>upKeyPressed: (in category 'event handling') ----- upKeyPressed: anEvent self selectedPreferenceIndex: (self selectedPreferenceIndex - 1 max: 1). ! ----- Method: PreferenceBrowserMorph>>update: (in category 'updating') ----- update: aSymbol super update: aSymbol. aSymbol == #selectedPreference ifTrue: [self updateSelectedPreference]. aSymbol == #selectedCategoryIndex ifTrue: [self updateSelectedCategoryPreferences].! ----- Method: PreferenceBrowserMorph>>updateSelectedCategoryPreferences (in category 'updating') ----- updateSelectedCategoryPreferences Cursor wait showWhile: [self preferenceList hScrollBarValue: 0; vScrollBarValue: 0. self preferenceList scroller removeAllMorphs. self preferenceList scroller addMorphBack: self newPreferenceListInnerPanel. self adjustPreferenceListItemsWidth]! ----- Method: PreferenceBrowserMorph>>updateSelectedPreference (in category 'updating') ----- updateSelectedPreference | index | self selectedCategory ifNotNil: [self turnOffSelectedPreference]. index := self selectedPreferenceIndex. index = 0 ifTrue: [^self]. self turnOnSelectedPreference.! ----- Method: Preferences class>>addPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector:viewRegistry: (in category '*PreferenceBrowser') ----- addPreference: aName categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: aViewRegistry "For compatibility with the old set of protocols" ^self addPreference: aName categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector type: (PreferenceViewRegistry typeOfRegistry: aViewRegistry).! Morph subclass: #PBPreferenceButtonMorph instanceVariableNames: 'moreButton model preference preferenceMorphicView preferenceView' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PBPreferenceButtonMorph class>>preference: (in category 'instance creation') ----- preference: aPreference ^self preference: aPreference model: nil! ----- Method: PBPreferenceButtonMorph class>>preference:model: (in category 'instance creation') ----- preference: aPreference model: aModel ^self new initializeWithPreference: aPreference model: aModel; yourself.! ----- Method: PBPreferenceButtonMorph>>actionButtons (in category 'extra controls') ----- actionButtons ^self preferenceView actions collect: [:aTuple | self basicButton label: aTuple first; target: aTuple second; actionSelector: aTuple third; arguments: aTuple fourth; setBalloonText: aTuple fifth ]! ----- Method: PBPreferenceButtonMorph>>addExtraControls (in category 'extra controls') ----- addExtraControls | m | m := self horizontalPanel cellInset: 3; addAllMorphs: self actionButtons; addMorphBack: self horizontalFiller; addMorphBack: self moreButton; yourself. self addMorphBack: (self blankSpaceOf: 2@2); addMorphBack: self preferenceHelpTextMorph; fullBounds; "to force a layout compute needed by the textMorphs's autoFit" addMorphBack: m ! ----- Method: PBPreferenceButtonMorph>>advancedOptionsSelected (in category 'extra controls') ----- advancedOptionsSelected self preferenceView offerPreferenceNameMenu: self model! ----- Method: PBPreferenceButtonMorph>>basicButton (in category 'utility methods') ----- basicButton | button | button := SimpleButtonMorph new. button borderWidth: 1; borderColor: self paneColor; on: #mouseEnter send: #value to: [button borderWidth: 2]; on: #mouseLeave send: #value to: [button borderWidth: 1]; vResizing: #rigid; height: (TextStyle defaultFont height + 4); useSquareCorners; clipSubmorphs: true; color: self paneColor muchLighter; target: self. ^button! ----- Method: PBPreferenceButtonMorph>>basicPanel (in category 'utility methods') ----- basicPanel ^BorderedMorph new beTransparent; extent: 0@0; borderWidth: 0; layoutInset: 0; cellInset: 0; layoutPolicy: TableLayout new; listCentering: #topLeft; cellPositioning: #center; hResizing: #spaceFill; vResizing: #shrinkWrap; yourself! ----- Method: PBPreferenceButtonMorph>>blankSpaceOf: (in category 'utility methods') ----- blankSpaceOf: aPoint ^Morph new beTransparent; extent: aPoint; yourself! ----- Method: PBPreferenceButtonMorph>>caseInsensitiveBeginsWith:in: (in category 'utility methods') ----- caseInsensitiveBeginsWith: prefix in: string ^(string findString: prefix startingAt: 1 caseSensitive: false) = 1! ----- Method: PBPreferenceButtonMorph>>highlightOff (in category 'highlighting') ----- highlightOff self beTransparent. self label color: Color black. self removeExtraControls.! ----- Method: PBPreferenceButtonMorph>>highlightOn (in category 'highlighting') ----- highlightOn self color: (Color gray alpha: 0.1). self addExtraControls.! ----- Method: PBPreferenceButtonMorph>>horizontalFiller (in category 'utility methods') ----- horizontalFiller ^self horizontalPanel hResizing: #spaceFill; yourself.! ----- Method: PBPreferenceButtonMorph>>horizontalPanel (in category 'utility methods') ----- horizontalPanel ^self basicPanel cellPositioning: #center; listDirection: #leftToRight; yourself.! ----- Method: PBPreferenceButtonMorph>>initializeLayout (in category 'initialization') ----- initializeLayout self layoutPolicy: TableLayout new; beTransparent; layoutInset: 0; cellInset: 0; listCentering: #topLeft; cellPositioning: #topLeft; listDirection: #topToBottom; hResizing: #spaceFill; vResizing: #shrinkWrap. ! ----- Method: PBPreferenceButtonMorph>>initializeWithPreference:model: (in category 'initialization') ----- initializeWithPreference: aPreference model: aModel preference := aPreference. model := aModel. self initializeLayout. self addMorphBack: self preferenceMorphicView. self highlightOff.! ----- Method: PBPreferenceButtonMorph>>label (in category 'preference accessing') ----- label ^self preferenceMorphicView firstSubmorph! ----- Method: PBPreferenceButtonMorph>>model (in category 'accessing') ----- model ^model! ----- Method: PBPreferenceButtonMorph>>moreButton (in category 'extra controls') ----- moreButton ^moreButton ifNil: [moreButton := self basicButton label: 'more' translated; setBalloonText: 'Click here for advanced options'translated; actionSelector: #advancedOptionsSelected]! ----- Method: PBPreferenceButtonMorph>>paneColor (in category 'utility methods') ----- paneColor | browser | browser := (self ownerChain detect: [:ea | ea isKindOf: PreferenceBrowserMorph] ifNone: [^Color black]) . ^browser paneColor! ----- Method: PBPreferenceButtonMorph>>preference (in category 'preference accessing') ----- preference ^preference! ----- Method: PBPreferenceButtonMorph>>preferenceHelp (in category 'preference accessing') ----- preferenceHelp | help name | help := self preference helpString withBlanksTrimmed. name := self preference name. (self caseInsensitiveBeginsWith: name in: help) ifTrue: [help := help allButFirst: name size]. (help notEmpty and: [help first = $:]) ifTrue: [help := help allButFirst]. ^help withBlanksTrimmed. ! ----- Method: PBPreferenceButtonMorph>>preferenceHelpText (in category 'preference accessing') ----- preferenceHelpText ^self preferenceHelp asText addAttribute: TextEmphasis italic; yourself.! ----- Method: PBPreferenceButtonMorph>>preferenceHelpTextMorph (in category 'extra controls') ----- preferenceHelpTextMorph | text tm | text := self preferenceHelpText. tm := TextMorph new contents: text; wrapOnOff; hResizing: #spaceFill; vResizing: #shrinkWrap; lock: true; visible: text notEmpty; yourself. "we don't want an empty textmorph showing" tm isAutoFit ifFalse: [tm autoFitOnOff]. ^tm.! ----- Method: PBPreferenceButtonMorph>>preferenceMorphicView (in category 'preference accessing') ----- preferenceMorphicView ^preferenceMorphicView ifNil: [preferenceMorphicView := self preferenceView representativeButtonWithColor: Color transparent inPanel: self model. preferenceMorphicView hResizing: #spaceFill. ^preferenceMorphicView]! ----- Method: PBPreferenceButtonMorph>>preferenceView (in category 'preference accessing') ----- preferenceView ^preferenceView ifNil: [preferenceView := self preference viewForPanel: self model.]! ----- Method: PBPreferenceButtonMorph>>removeExtraControls (in category 'extra controls') ----- removeExtraControls self submorphs copyWithoutFirst do: [:ea | ea delete]! ----- Method: PBPreferenceButtonMorph>>verticalPanel (in category 'utility methods') ----- verticalPanel ^self basicPanel cellPositioning: #topLeft; listDirection: #topToBottom; yourself.! Model subclass: #PreferenceBrowser instanceVariableNames: 'selectedCategoryIndex selectedPreference searchPattern searchResults lastExecutedSearch preferences title' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PreferenceBrowser class>>initialize (in category 'class initialization') ----- initialize self registerWindowColor; registerInOpenMenu; registerInFlaps! ----- Method: PreferenceBrowser class>>open (in category 'instance creation') ----- open | browser | browser := self new. (PreferenceBrowserMorph withModel: browser) openInWorld. ^browser. ! ----- Method: PreferenceBrowser class>>prototypicalToolWindow (in category 'instance creation') ----- prototypicalToolWindow | window | window := PreferenceBrowserMorph withModel: self new. window applyModelExtent. ^window! ----- Method: PreferenceBrowser class>>registerInFlaps (in category 'class initialization') ----- registerInFlaps Flaps registerQuad: { #PreferenceBrowser. #prototypicalToolWindow. 'Preference Browser' translated. 'A tool for expressing personal preferences for numerous options' translated } forFlapNamed: 'Tools' translated. Flaps replaceToolsFlap! ----- Method: PreferenceBrowser class>>registerInOpenMenu (in category 'class initialization') ----- registerInOpenMenu (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ TheWorldMenu unregisterOpenCommand: 'Preference Browser'. TheWorldMenu registerOpenCommand: {'Preference Browser'. {self. #open}}]. ! ----- Method: PreferenceBrowser class>>registerWindowColor (in category 'class initialization') ----- registerWindowColor (Preferences windowColorFor: self name) = Color white ifTrue: [ Preferences setWindowColorFor: self name to: (Color colorFrom: self windowColorSpecification brightColor) ].! ----- Method: PreferenceBrowser class>>unload (in category 'class initialization') ----- unload self unregisterFromOpenMenu; unregisterFromFlaps.! ----- Method: PreferenceBrowser class>>unregisterFromFlaps (in category 'class initialization') ----- unregisterFromFlaps Flaps unregisterQuadsWithReceiver: self; replaceToolsFlap! ----- Method: PreferenceBrowser class>>unregisterFromOpenMenu (in category 'class initialization') ----- unregisterFromOpenMenu (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [TheWorldMenu unregisterOpenCommand: 'Preference Browser']. ! ----- Method: PreferenceBrowser class>>windowColorSpecification (in category 'window color') ----- windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Preference Browser' brightColor: #(0.645 1.0 1.0) pastelColor: #(0.886 1.0 1.0) helpMessage: 'A tool for expressing personal preferences for numerous options.'! ----- Method: PreferenceBrowser>>allCategoryLabel (in category 'user interface') ----- allCategoryLabel ^'-- all --' translated! ----- Method: PreferenceBrowser>>allCategorySelected (in category 'accessing') ----- allCategorySelected ^self selectedCategory = self allCategoryLabel! ----- Method: PreferenceBrowser>>allPreferences (in category 'accessing') ----- allPreferences ^ preferences allPreferenceObjects asSortedCollection: [:pref1 :pref2 | pref1 viewRegistry viewOrder >categoryList (in category 'accessing') ----- categoryList ^OrderedCollection new add: self allCategoryLabel; addAll: preferences categoryNames asSortedCollection; add: self searchResultsCategoryLabel; yourself. ! ----- Method: PreferenceBrowser>>defaultSelected (in category 'preferences search') ----- defaultSelected Preferences chooseInitialSettings! ----- Method: PreferenceBrowser>>findCategoryFromPreference: (in category 'find') ----- 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: #selectedCategory: argument: aCategory]. aMenu popUpInWorld! ----- Method: PreferenceBrowser>>helpSelected (in category 'preferences search') ----- helpSelected "Open up a workspace with explanatory info in it about the Preference Browser" Workspace new contents: self helpText; openLabel: self windowTitle.! ----- Method: PreferenceBrowser>>helpText (in category 'preferences search') ----- helpText ^(String streamContents: [:str | str nextPutAll: 'Many aspects of the system are goberned by the settings of various ''Preferences''. Click on any of the categories shown at the left list to see all the preferences in that category. Or type into the search box at the bottom of the window, 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 text *or* if anything in the preference''s help text does. To find out more about any particular Preference just select it and its help text will appear. Some preferences can be ''local'' instead of global. When a preference is set as global its value will apply to whatever project you are in. A local preference will only be valid in the project that you set it in. The ''Save'' button allow you to quickly save your current settings so it can later be restored with the ''Load'' button. To carry your settings to another Squeak you might want to use the ''Save to disk'' and ''Load from disk'' buttons. The save to disk option will store all your settings in a ''my.prefs'' file in your Squeak''s current directory. Lastly, you can use the "theme..." button to set multiple preferences all at once; click on the "theme..." button and try the themes already provided with your Squeak image.']) translated! ----- Method: PreferenceBrowser>>initialExtent (in category 'user interface') ----- initialExtent ^ 660@440! ----- Method: PreferenceBrowser>>initialize (in category 'initialize-release') ----- initialize preferences := Preferences. title := 'Preference Browser'.! ----- Method: PreferenceBrowser>>lastExecutedSearch (in category 'accessing') ----- lastExecutedSearch ^lastExecutedSearch! ----- Method: PreferenceBrowser>>lastExecutedSearch: (in category 'accessing') ----- lastExecutedSearch: aTextOrString ^lastExecutedSearch:= aTextOrString! ----- Method: PreferenceBrowser>>loadFromDiskSelected (in category 'preferences search') ----- loadFromDiskSelected preferences restorePreferencesFromDisk! ----- Method: PreferenceBrowser>>loadSelected (in category 'preferences search') ----- loadSelected preferences restorePersonalPreferences ! ----- Method: PreferenceBrowser>>nonSpecialCategorySelected (in category 'accessing') ----- nonSpecialCategorySelected ^self allCategorySelected not & self searchResultsCategorySelected not! ----- Method: PreferenceBrowser>>preferences (in category 'accessing') ----- preferences ^ preferences! ----- Method: PreferenceBrowser>>preferencesInCategory: (in category 'accessing') ----- preferencesInCategory: aCategory ^(preferences preferenceObjectsInCategory: aCategory) asSortedCollection: [:pref1 :pref2 | pref1 viewRegistry viewOrder >representsSameBrowseeAs: (in category 'user interface') ----- representsSameBrowseeAs: anotherModel "If an existing Preference browser is on-screen, use it." ^ self class = anotherModel class! ----- Method: PreferenceBrowser>>saveSelected (in category 'preferences search') ----- saveSelected preferences savePersonalPreferences ! ----- Method: PreferenceBrowser>>saveToDiskSelected (in category 'preferences search') ----- saveToDiskSelected preferences storePreferencesToDisk! ----- Method: PreferenceBrowser>>searchFieldLegend (in category 'accessing') ----- searchFieldLegend ^''.! ----- Method: PreferenceBrowser>>searchPattern (in category 'accessing') ----- searchPattern ^searchPattern ifNil: [searchPattern := self searchFieldLegend]! ----- Method: PreferenceBrowser>>searchPattern: (in category 'accessing') ----- searchPattern: aStringOrText aStringOrText ifEmpty: [searchPattern := self searchFieldLegend] ifNotEmpty: [searchPattern := aStringOrText asString]. self changed: #searchPattern. ^true! ----- Method: PreferenceBrowser>>searchPatternNeverTriggered (in category 'accessing') ----- searchPatternNeverTriggered ^self searchPattern! ----- Method: PreferenceBrowser>>searchPreferencesFor: (in category 'preferences search') ----- searchPreferencesFor: pattern | result | result := pattern asString asLowercase withBlanksTrimmed. result ifEmpty: [^self]. searchResults := self allPreferences select: [:aPreference | (aPreference name includesSubstring: result caseSensitive: false) or: [aPreference helpString includesSubstring: result caseSensitive: false]]. self selectSearchResultsCategory. self lastExecutedSearch: pattern. ! ----- Method: PreferenceBrowser>>searchResults (in category 'accessing') ----- searchResults ^searchResults ifNil: [searchResults := #()]! ----- Method: PreferenceBrowser>>searchResultsCategoryLabel (in category 'user interface') ----- searchResultsCategoryLabel ^'-- search results --' translated! ----- Method: PreferenceBrowser>>searchResultsCategorySelected (in category 'accessing') ----- searchResultsCategorySelected ^self selectedCategory = self searchResultsCategoryLabel! ----- Method: PreferenceBrowser>>searchSelected (in category 'buttons callbacks') ----- searchSelected self searchPreferencesFor: self searchPattern.! ----- Method: PreferenceBrowser>>selectFirstPreferenceOrNil (in category 'accessing') ----- selectFirstPreferenceOrNil | prefs | self selectedCategory ifNil: [^self selectedPreference: nil]. prefs := self preferencesInCategory: self selectedCategory. prefs isEmpty ifTrue: [^self selectedPreference: nil]. self selectedPreference: prefs first.! ----- Method: PreferenceBrowser>>selectSearchResultsCategory (in category 'accessing') ----- selectSearchResultsCategory self selectedCategoryIndex: (self categoryList indexOf: self searchResultsCategoryLabel)! ----- Method: PreferenceBrowser>>selectedCategory (in category 'accessing') ----- selectedCategory ^self categoryList at: selectedCategoryIndex ifAbsent: []! ----- Method: PreferenceBrowser>>selectedCategory: (in category 'accessing') ----- selectedCategory: aCategorySymbol self selectedCategoryIndex: (self categoryList indexOf: aCategorySymbol ifAbsent: [0]).! ----- Method: PreferenceBrowser>>selectedCategoryIndex (in category 'accessing') ----- selectedCategoryIndex ^selectedCategoryIndex ifNil: [selectedCategoryIndex := 0].! ----- Method: PreferenceBrowser>>selectedCategoryIndex: (in category 'accessing') ----- selectedCategoryIndex: anIndex anIndex = 0 ifTrue: [^self]. self selectedPreference: nil. selectedCategoryIndex := anIndex. self changed: #selectedCategoryIndex.! ----- Method: PreferenceBrowser>>selectedCategoryPreferences (in category 'accessing') ----- selectedCategoryPreferences self allCategorySelected ifTrue: [^self allPreferences]. self searchResultsCategorySelected ifTrue: [^self searchResults]. ^self preferencesInCategory: self selectedCategory. ! ----- Method: PreferenceBrowser>>selectedPreference (in category 'accessing') ----- selectedPreference ^selectedPreference! ----- Method: PreferenceBrowser>>selectedPreference: (in category 'accessing') ----- selectedPreference: aPreference selectedPreference := aPreference. self changed: #selectedPreference. self changed: #selectedPreferenceIndex. self changed: #selectedPreferenceHelpText.! ----- Method: PreferenceBrowser>>selectedPreferenceHelpText (in category 'accessing') ----- selectedPreferenceHelpText self selectedPreference ifNil: [^'']. ^self selectedPreference helpString withBlanksTrimmed.! ----- Method: PreferenceBrowser>>selectedPreferenceIndex (in category 'accessing') ----- selectedPreferenceIndex ^self selectedCategoryPreferences indexOf: self selectedPreference ifAbsent: [0]! ----- Method: PreferenceBrowser>>selectedPreferenceIndex: (in category 'accessing') ----- selectedPreferenceIndex: anIndex anIndex = 0 ifTrue: [^self]. self selectedPreference: (self selectedCategoryPreferences at: anIndex).! ----- Method: PreferenceBrowser>>stepAt:in: (in category 'stepping') ----- stepAt: millisecondClockValue in: aWindow super stepAt: millisecondClockValue in: aWindow. self searchPattern ~= self lastExecutedSearch ifTrue: [self searchPreferencesFor: self searchPattern].! ----- Method: PreferenceBrowser>>themeSelected (in category 'preferences search') ----- themeSelected preferences offerThemesMenu! ----- Method: PreferenceBrowser>>wantsStepsIn: (in category 'stepping') ----- wantsStepsIn: aWindow ^true.! ----- Method: PreferenceBrowser>>windowTitle (in category 'user interface') ----- windowTitle ^ title translated! ----- Method: Preference>>representativeButtonWithColor:inPanel: (in category '*PreferenceBrowser') ----- representativeButtonWithColor: aColor inPanel: aPanel | view | view := self viewForPanel: aPanel. ^view ifNotNil: [view representativeButtonWithColor: aColor inPanel: aPanel]! ----- Method: Preference>>selectors (in category '*PreferenceBrowser') ----- selectors "for browsing senders" ^{name}! ----- Method: Preference>>viewClassForPanel: (in category '*PreferenceBrowser') ----- viewClassForPanel: aPreferencePanel ^self viewRegistry viewClassFor: aPreferencePanel! ----- Method: Preference>>viewForPanel: (in category '*PreferenceBrowser') ----- viewForPanel: aPreferencePanel | viewClass | viewClass := self viewClassForPanel: aPreferencePanel. ^viewClass ifNotNil: [viewClass preference: self]! ----- Method: Preference>>viewRegistry (in category '*PreferenceBrowser') ----- viewRegistry ^PreferenceViewRegistry forType: self type! Object subclass: #PreferenceView instanceVariableNames: 'preference' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! PreferenceView class instanceVariableNames: 'registeredClasses'! !PreferenceView commentStamp: '' prior: 0! My subclasses instances are responsible for building the visual representation of each kind of preference.! PreferenceView class instanceVariableNames: 'registeredClasses'! PreferenceView subclass: #PBPreferenceView instanceVariableNames: 'actions' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! !PBPreferenceView commentStamp: '' prior: 0! I am just a refactor of all the common method of the PreferenceBrowser preference views! PBPreferenceView subclass: #PBBooleanPreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! !PBBooleanPreferenceView commentStamp: '' prior: 0! I am responsible for building the visual representation of a preference that accepts true and false values. This view is aimed to be used inside a PreferenceBrowser panel.! ----- Method: PBBooleanPreferenceView class>>initialize (in category 'class initialization') ----- initialize PreferenceViewRegistry ofBooleanPreferences register: self. ! ----- Method: PBBooleanPreferenceView class>>unload (in category 'class initialization') ----- unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofBooleanPreferences unregister: self] on: Error do:[].! ----- Method: PBBooleanPreferenceView>>enabledButton (in category 'user interface') ----- enabledButton | aButton aLabel | aButton := UpdatingThreePhaseButtonMorph checkBox target: self preference; actionSelector: #togglePreferenceValue; getSelector: #preferenceValue; yourself. aLabel := (StringMorph contents: 'enabled' translated font: (StrikeFont familyName: TextStyle defaultFont familyName size: TextStyle defaultFont pointSize - 1)). ^self horizontalPanel addMorphBack: aButton; addMorphBack: aLabel; yourself.! ----- Method: PBBooleanPreferenceView>>localToProjectButton (in category 'user interface') ----- localToProjectButton | aButton aLabel | aButton := UpdatingThreePhaseButtonMorph checkBox target: self preference; actionSelector: #toggleProjectLocalness; getSelector: #localToProject; yourself. aLabel := (StringMorph contents: 'local' translated font: (StrikeFont familyName: TextStyle defaultFont familyName size: TextStyle defaultFont pointSize - 1)). ^self horizontalPanel addMorphBack: aButton; addMorphBack: aLabel; yourself.! ----- Method: PBBooleanPreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferencesPanel ^self horizontalPanel layoutInset: 2; cellInset: 7; color: aColor; addMorphBack: (StringMorph contents: self preference name); addMorphBack: self horizontalFiller; addMorphBack: self enabledButton; addMorphBack: self localToProjectButton; yourself.! PBPreferenceView subclass: #PBHaloThemePreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! !PBHaloThemePreferenceView commentStamp: '' prior: 0! I am responsible for building the button for the Halo Theme preference! ----- Method: PBHaloThemePreferenceView class>>initialize (in category 'class initialization') ----- initialize PreferenceViewRegistry ofHaloThemePreferences register: self.! ----- Method: PBHaloThemePreferenceView class>>unload (in category 'class initialization') ----- unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofHaloThemePreferences unregister: self] on: Error do:[]! ----- Method: PBHaloThemePreferenceView>>haloThemeRadioButtons (in category 'user interface') ----- haloThemeRadioButtons "Answer a column of butons representing the choices of halo theme" | buttonColumn | buttonColumn := self verticalPanel. #( (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 aRadioButton aLabel | aRadioButton := UpdatingThreePhaseButtonMorph radioButton target: Preferences; setBalloonText: quad fourth; actionSelector: #installHaloTheme:; getSelector: quad third; arguments: (Array with: quad first); yourself. aLabel := (StringMorph contents: quad second asString) setBalloonText: quad fourth; yourself. aRow := self horizontalPanel cellInset: 4; addMorphBack: aRadioButton; addMorphBack: aLabel. buttonColumn addMorphBack: aRow]. ^ buttonColumn "(Preferences preferenceAt: #haloTheme) view tearOffButton"! ----- Method: PBHaloThemePreferenceView>>initialize (in category 'initialization') ----- initialize self addActionTitled: 'edit custom halos' target: Preferences selector: #editCustomHalos arguments: {} balloonText: 'Click here to edit the method that defines the custom halos' translated.! ----- Method: PBHaloThemePreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferencesPanel | innerPanel | innerPanel := self horizontalPanel addMorphBack: (self blankSpaceOf: 10@0); addMorphBack: self haloThemeRadioButtons; yourself. ^self verticalPanel color: aColor; layoutInset: 2; addMorphBack: (StringMorph contents: self preference name); addMorphBack: innerPanel.! PBPreferenceView subclass: #PBNumericPreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PBNumericPreferenceView class>>initialize (in category 'class initialization') ----- initialize PreferenceViewRegistry ofNumericPreferences register: self.! ----- Method: PBNumericPreferenceView class>>unload (in category 'class initialization') ----- unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofNumericPreferences unregister: self] on: Error do:[].! ----- Method: PBNumericPreferenceView>>preferenceValue (in category 'user interface') ----- preferenceValue ^self preference preferenceValue asString! ----- Method: PBNumericPreferenceView>>preferenceValue: (in category 'user interface') ----- preferenceValue: aTextOrString (aTextOrString notEmpty and: [aTextOrString asString isAllDigits]) ifFalse: [^false]. self preference preferenceValue: aTextOrString asNumber. ^true.! ----- Method: PBNumericPreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferenceBrowser ^self horizontalPanel layoutInset: 2; color: aColor; cellInset: 20; cellPositioning: #center; addMorphBack: (StringMorph contents: self preference name); addMorphBack: self textField; yourself.! ----- Method: PBNumericPreferenceView>>textField (in category 'user interface') ----- textField ^(PluggableTextMorph on: self text: #preferenceValue accept: #preferenceValue:) hideScrollBarsIndefinitely; borderColor: #inset; acceptOnCR: true; color: Color gray veryMuchLighter; vResizing: #rigid; hResizing: #spaceFill; height: TextStyle defaultFont height + 6; yourself.! ----- Method: PBPreferenceView class>>handlesPanel: (in category 'view registry') ----- handlesPanel: aPreferencePanel ^aPreferencePanel isKindOf: PreferenceBrowser! ----- Method: PBPreferenceView>>actions (in category 'actions') ----- actions ^actions ifNil: [actions := OrderedCollection new.]! ----- Method: PBPreferenceView>>addActionTitled:target:selector:arguments:balloonText: (in category 'actions') ----- addActionTitled: aTitle target: aTarget selector: aSelector arguments: aCollection balloonText: aText self actions add: { aTitle. aTarget. aSelector. aCollection. aText }! ----- Method: PBPreferenceView>>basicPanel (in category 'user interface') ----- basicPanel ^BorderedMorph new beTransparent; extent: 0@0; borderWidth: 0; layoutInset: 0; cellInset: 2; layoutPolicy: TableLayout new; listCentering: #topLeft; cellPositioning: #center; hResizing: #shrinkWrap; vResizing: #shrinkWrap; yourself! ----- Method: PBPreferenceView>>blankSpaceOf: (in category 'user interface') ----- blankSpaceOf: aPoint ^Morph new beTransparent; extent: aPoint; yourself! ----- Method: PBPreferenceView>>horizontalFiller (in category 'user interface') ----- horizontalFiller ^self horizontalPanel hResizing: #spaceFill; yourself.! ----- Method: PBPreferenceView>>horizontalPanel (in category 'user interface') ----- horizontalPanel ^self basicPanel cellPositioning: #center; listDirection: #leftToRight; yourself.! ----- Method: PBPreferenceView>>offerPreferenceNameMenu: (in category 'user interface') ----- offerPreferenceNameMenu: aPreferenceBrowser "the user clicked on a preference name -- put up a menu" | aMenu | aMenu := MenuMorph new defaultTarget: self preference; 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' translated target: self systemNavigation selector: #browseAllSelect:name:autoSelect: argumentList: {[:m | self preference selectors anySatisfy: [:sel | m hasLiteralThorough: sel]]. 'Preference senders: {1}' translated format: {self preference name}. self preference selectors first}. 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: aPreferenceBrowser 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! ----- Method: PBPreferenceView>>verticalPanel (in category 'user interface') ----- verticalPanel ^self basicPanel cellPositioning: #topLeft; listDirection: #topToBottom; yourself.! PBPreferenceView subclass: #PBTextPreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PBTextPreferenceView class>>initialize (in category 'class initialization') ----- initialize PreferenceViewRegistry ofTextPreferences register: self.! ----- Method: PBTextPreferenceView class>>unload (in category 'class initialization') ----- unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofTextPreferences unregister: self] on: Error do:[]! ----- Method: PBTextPreferenceView>>preferenceValue (in category 'user interface') ----- preferenceValue ^self preference preferenceValue ifNil: ['']! ----- Method: PBTextPreferenceView>>preferenceValue: (in category 'user interface') ----- preferenceValue: aTextOrString self preference preferenceValue: aTextOrString asString. ^true.! ----- Method: PBTextPreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferenceBrowser ^self horizontalPanel layoutInset: 2; color: aColor; cellInset: 20; cellPositioning: #center; addMorphBack: (StringMorph contents: self preference name); addMorphBack: self textField; yourself.! ----- Method: PBTextPreferenceView>>textField (in category 'user interface') ----- textField ^(PluggableTextMorph on: self text: #preferenceValue accept: #preferenceValue:) hideScrollBarsIndefinitely; borderColor: #inset; acceptOnCR: true; color: Color gray veryMuchLighter; vResizing: #rigid; hResizing: #spaceFill; height: TextStyle defaultFont height + 6; yourself.! ----- Method: PreferenceView class>>handlesPanel: (in category 'view registry') ----- handlesPanel: aPreferencePanel self subclassResponsibility ! ----- Method: PreferenceView class>>preference: (in category 'instance creation') ----- preference: aPreference ^self new initializeWithPreference: aPreference; yourself! ----- Method: PreferenceView>>initializeWithPreference: (in category 'initialization') ----- initializeWithPreference: aPreference preference := aPreference! ----- Method: PreferenceView>>preference (in category 'accessing') ----- preference ^preference! ----- Method: PreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferencesPanel self subclassResponsibility ! ----- Method: PreferenceView>>tearOffButton (in category 'user interface') ----- 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! Object subclass: #PreferenceViewRegistry instanceVariableNames: 'registeredClasses viewOrder' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! PreferenceViewRegistry class instanceVariableNames: 'registries'! !PreferenceViewRegistry commentStamp: '' 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 instanceVariableNames: 'registries'! ----- Method: PreferenceViewRegistry class>>forType: (in category 'accessing') ----- forType: typeName "Answer the preference registry for the given type name" ^typeName caseOf:{ [#Boolean] -> [self ofBooleanPreferences]. [#Color] -> [self ofColorPreferences]. [#Font] -> [self ofFontPreferences]. [#Number] -> [self ofNumericPreferences]. [#String] -> [self ofTextPreferences]. [#Halo] -> [self ofHaloThemePreferences]. [#WindowColor] -> [self registryOf: #windowColorPreferences] } otherwise:[self registryOf: typeName].! ----- Method: PreferenceViewRegistry class>>initialize (in category 'class initialization') ----- initialize "Ensure we aren't carrying obsolete references" self removeObsolete.! ----- Method: PreferenceViewRegistry class>>ofBooleanPreferences (in category 'instance creation') ----- ofBooleanPreferences ^(self registryOf: #booleanPreferences) viewOrder: 1; yourself.! ----- Method: PreferenceViewRegistry class>>ofColorPreferences (in category 'instance creation') ----- ofColorPreferences ^(self registryOf: #colorPreferences) viewOrder: 5; yourself.! ----- Method: PreferenceViewRegistry class>>ofFontPreferences (in category 'instance creation') ----- ofFontPreferences ^(self registryOf: #fontPreferences) viewOrder: 4; yourself.! ----- Method: PreferenceViewRegistry class>>ofHaloThemePreferences (in category 'instance creation') ----- ofHaloThemePreferences ^(self registryOf: #haloThemePreferences) viewOrder: 2; yourself.! ----- Method: PreferenceViewRegistry class>>ofNumericPreferences (in category 'instance creation') ----- ofNumericPreferences ^(self registryOf: #numericPreferences) viewOrder: 3; yourself.! ----- Method: PreferenceViewRegistry class>>ofTextPreferences (in category 'instance creation') ----- ofTextPreferences ^(self registryOf: #textPreferences) viewOrder: 3; yourself.! ----- Method: PreferenceViewRegistry class>>registries (in category 'instance creation') ----- registries ^registries ifNil: [registries := Dictionary new]! ----- Method: PreferenceViewRegistry class>>registryOf: (in category 'instance creation') ----- registryOf: aSymbol ^self registries at: aSymbol ifAbsentPut: [self new]! ----- Method: PreferenceViewRegistry class>>removeObsolete (in category 'class initialization') ----- removeObsolete "PreferenceViewRegistry removeObsolete" "Remove obsolete entries from the registries" self registries do:[:viewRegistry| viewRegistry registeredClasses copy do:[:rClass| rClass isObsolete ifTrue:[viewRegistry unregister: rClass]]].! ----- Method: PreferenceViewRegistry class>>typeOfRegistry: (in category 'accessing') ----- typeOfRegistry: aRegistry "Answer the type name for a particular view registry" ^aRegistry caseOf:{ [self ofBooleanPreferences] -> [#Boolean]. [self ofColorPreferences] -> [#Color]. [self ofFontPreferences] -> [#Font]. [self ofNumericPreferences] -> [#Number]. [self ofTextPreferences] -> [#String]. [self ofHaloThemePreferences] -> [#Halo]. [self registryOf: #windowColorPreferences] -> [#WindowColor]. } otherwise:[self registries keyAtIdentityValue: aRegistry ifAbsent:[nil]].! ----- Method: PreferenceViewRegistry>>initialize (in category 'initialize-release') ----- initialize viewOrder := 1.! ----- Method: PreferenceViewRegistry>>register: (in category 'view registry') ----- register: aProviderClass (self registeredClasses includes: aProviderClass) ifFalse: [self registeredClasses add: aProviderClass].! ----- Method: PreferenceViewRegistry>>registeredClasses (in category 'view registry') ----- registeredClasses ^registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ----- Method: PreferenceViewRegistry>>unregister: (in category 'view registry') ----- unregister: aProviderClass self registeredClasses remove: aProviderClass ifAbsent: []! ----- Method: PreferenceViewRegistry>>viewClassFor: (in category 'view registry') ----- viewClassFor: aPreferencePanel ^self registeredClasses detect: [:aViewClass| aViewClass handlesPanel: aPreferencePanel] ifNone: [].! ----- Method: PreferenceViewRegistry>>viewOrder (in category 'view order') ----- viewOrder "answer the order in which the registered views should appear relative to the other views" ^viewOrder! ----- Method: PreferenceViewRegistry>>viewOrder: (in category 'view order') ----- viewOrder: aNumber viewOrder := aNumber! ----- Method: PragmaPreference>>selectors (in category '*PreferenceBrowser') ----- selectors "for browsing senders" ^ {getter. setter}! From commits at source.squeak.org Fri Jun 5 20:12:50 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:12:52 2015 Subject: [squeak-dev] Squeak 4.6: 46Deprecated-dtl.4.mcz Message-ID: Chris Muller uploaded a new version of 46Deprecated to project Squeak 4.6: http://source.squeak.org/squeak46/46Deprecated-dtl.4.mcz ==================== Summary ==================== Name: 46Deprecated-dtl.4 Author: dtl Time: 30 May 2015, 6:14:05.154 pm UUID: 69e9c6e3-c82e-445b-b82d-adc42cacb06b Ancestors: 46Deprecated-mt.3 Provide an implementation of MCMcmUpdater class>>useLatestPackagesFrom: because an older image may be referencing it while trying to update itself from a block in the earler class side implementation, in which case we should delegate to the current default instance of MCMcmUpdater. ==================== Snapshot ==================== SystemOrganization addCategory: #'46Deprecated-Morphic'! PluggableListMorph subclass: #PluggableMessageCategoryListMorph instanceVariableNames: 'getRawListSelector priorRawList' classVariableNames: '' poolDictionaries: '' category: '46Deprecated-Morphic'! !PluggableMessageCategoryListMorph commentStamp: '' prior: 0! A variant of PluggableListMorph designed specially for efficient handling of the --all-- feature in message-list panes. In order to be able *quickly* to check whether there has been an external change to the list, we cache the raw list for identity comparison (the actual list is a combination of the --all-- element and the the actual list).! ----- Method: PluggableMessageCategoryListMorph class>>on:list:selected:changeSelected:menu:keystroke:getRawListSelector: (in category 'as yet unclassified') ----- 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! ----- Method: PluggableMessageCategoryListMorph>>getList (in category 'model access') ----- 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! ----- Method: PluggableMessageCategoryListMorph>>on:list:selected:changeSelected:menu:keystroke:getRawListSelector: (in category 'as yet unclassified') ----- 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! ----- Method: PluggableMessageCategoryListMorph>>verifyContents (in category 'updating') ----- 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]. existingSelection := self selection. self updateList. (anIndex := newList indexOf: existingSelection ifAbsent: [nil]) ifNotNil: [model noteSelectionIndex: anIndex for: getListSelector. self selectionIndex: anIndex] ifNil: [self changeModelSelection: 0]! ----- Method: MorphicProject>>exportSegmentWithCatagories:classes:fileName:directory: (in category '*46Deprecated') ----- exportSegmentWithCatagories: catList classes: classList 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 .extSeg. What do 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 | self flag: #toRemove. self halt. "unused" "world == World ifTrue: [^ false]." "self inform: 'Can''t send the current world out'." world ifNil: [^ false]. world presenter ifNil: [^ false]. ScrapBook default emptyScrapBook. 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. holder := Project allProjects. "force them in to outPointers, where DiskProxys are made" "Just export me, not my previous version" revertSeg := self parameterAt: #revertToMe. 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" catList do: [:sysCat | (SystemOrganization listAtCategoryNamed: sysCat asSymbol) do: [:symb | roots add: (Smalltalk at: symb); add: (Smalltalk at: symb) class]]. is := ImageSegment new copySmartRootsExport: roots asArray. "old way was (is := ImageSegment new copyFromRootsForExport: roots asArray)" is state = #tooBig ifTrue: [^ 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.' withCRs]. str isEmpty ifFalse: [ ans := (UIManager default chooseFrom: #('Do not write file' 'Write file anyway' 'Debug') title: str). ans = 1 ifTrue: [ revertSeg ifNotNil: [self projectParameterAt: #revertToMe put: revertSeg]. ^ false]. ans = 3 ifTrue: [self halt: 'Segment not written']]. is writeForExportWithSources: aFileName inDirectory: aDirectory. revertSeg ifNotNil: [self projectParameterAt: #revertToMe put: revertSeg]. holder. world flapTabs do: [:ft | (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]]. is arrayOfRoots do: [:obj | obj isScriptEditorMorph ifTrue: [obj unhibernate]]. ^ true ! ----- Method: HierarchyBrowser>>potentialClassNames (in category '*46Deprecated') ----- potentialClassNames "Answer the names of all the classes that could be viewed in this browser" ^ self classList collect: [:aName | aName copyWithout: $ ]! ----- Method: MCMcmUpdater class>>useLatestPackagesFrom: (in category '*46Deprecated') ----- useLatestPackagesFrom: repo "For overriding on a per repository basis. Implementation is now on the instance side, but is also maintained here because an older image may be trying to update to current and may still be evaluating a block in its class:>>updateFromRepositoriesMCMcmUpdater that expects thiis method to be present. Delegate to the current default instance." ^ self default useLatestPackagesFrom: repo ! ----- Method: ScrollPane>>alwaysShowHScrollBar: (in category '*46Deprecated') ----- alwaysShowHScrollBar: bool self flag: #deprecated. self setProperty: #hScrollBarAlways toValue: bool. bool ifTrue: [self hScrollBarPolicy: #always] ifFalse: [self hScrollBarPolicy: #whenNeeded]. self hHideOrShowScrollBar. ! ----- Method: ScrollPane>>alwaysShowScrollBars: (in category '*46Deprecated') ----- alwaysShowScrollBars: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self alwaysShowHScrollBar: bool; alwaysShowVScrollBar: bool. ! ----- Method: ScrollPane>>alwaysShowVScrollBar: (in category '*46Deprecated') ----- alwaysShowVScrollBar: bool self flag: #deprecated. self setProperty: #vScrollBarAlways toValue: bool. bool ifTrue: [self vScrollBarPolicy: #always] ifFalse: [self vScrollBarPolicy: #whenNeeded]. self vHideOrShowScrollBar. ! ----- Method: ScrollPane>>hInitScrollBarTEMPORARY (in category '*46Deprecated') ----- hInitScrollBarTEMPORARY "This is called lazily before the hScrollBar is accessed in a couple of places. It is provided to transition old ScrollPanes lying around that do not have an hScrollBar. Once it has been in the image for awhile, and all ScrollPanes have an hScrollBar, this method and it's references can be removed. " "Temporary method for filein of changeset" hScrollBar ifNil: [hScrollBar := ScrollBar new model: self slotName: 'hScrollBar'. hScrollBar borderWidth: 1; borderColor: Color black. self resizeScrollBars; setScrollDeltas; hideOrShowScrollBars]. ! ----- Method: ScrollPane>>hideHScrollBarIndefinitely: (in category '*46Deprecated') ----- hideHScrollBarIndefinitely: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self setProperty: #noHScrollBarPlease toValue: bool. bool ifTrue: [self hScrollBarPolicy: #never] ifFalse: [self hScrollBarPolicy: #whenNeeded]. self hHideOrShowScrollBar. ! ----- Method: ScrollPane>>hideScrollBarsIndefinitely: (in category '*46Deprecated') ----- hideScrollBarsIndefinitely: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self hideVScrollBarIndefinitely: bool. self hideHScrollBarIndefinitely: bool. ! ----- Method: ScrollPane>>hideVScrollBarIndefinitely: (in category '*46Deprecated') ----- hideVScrollBarIndefinitely: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self setProperty: #noVScrollBarPlease toValue: bool. bool ifTrue: [self vScrollBarPolicy: #never] ifFalse: [self vScrollBarPolicy: #whenNeeded]. self vHideOrShowScrollBar. ! ----- Method: ScrollPane>>isAScrollbarShowing (in category '*46Deprecated') ----- isAScrollbarShowing "Return true if a either retractable scroll bar is currently showing" self flag: #deprectaed. "mt: Use #isAnyScrollbarShowing" retractableScrollBar ifFalse:[^true]. ^self hIsScrollbarShowing or: [self vIsScrollbarShowing] ! ----- Method: ScrollPane>>showHScrollBarOnlyWhenNeeded: (in category '*46Deprecated') ----- showHScrollBarOnlyWhenNeeded: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self setProperty: #noHScrollBarPlease toValue: bool not. self setProperty: #hScrollBarAlways toValue: bool not. bool ifTrue: [self hScrollBarPolicy: #whenNeeded] ifFalse: [self hScrollBarPolicy: #never]. self hHideOrShowScrollBar. ! ----- Method: ScrollPane>>showScrollBarsOnlyWhenNeeded: (in category '*46Deprecated') ----- showScrollBarsOnlyWhenNeeded: bool self flag: #deprecated. self showHScrollBarOnlyWhenNeeded: bool. self showVScrollBarOnlyWhenNeeded: bool. ! ----- Method: ScrollPane>>showVScrollBarOnlyWhenNeeded: (in category '*46Deprecated') ----- showVScrollBarOnlyWhenNeeded: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self setProperty: #noVScrollBarPlease toValue: bool not. self setProperty: #vScrollBarAlways toValue: bool not. bool ifTrue: [self vScrollBarPolicy: #whenNeeded] ifFalse: [self vScrollBarPolicy: #never]. self vHideOrShowScrollBar. ! TextMorph subclass: #SearchBarMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: '46Deprecated-Morphic'! ----- Method: SearchBarMorph>>activate: (in category 'search') ----- activate: event event hand newKeyboardFocus: self. self selectAll! ----- Method: SearchBarMorph>>fillStyle (in category 'initialize') ----- fillStyle ^backgroundColor! ----- Method: SearchBarMorph>>initialize (in category 'initialize') ----- initialize super initialize. text := Text new. backgroundColor := TranslucentColor gray alpha: 0.3. self width: 200. self crAction: (MessageSend receiver: self selector: #smartSearch:). self setBalloonText: 'Searches for globals and methods'.! ----- Method: SearchBarMorph>>smartSearch: (in category 'search') ----- smartSearch: evt "Take the user input and perform an appropriate search" | input newContents | input := self contents asString ifEmpty:[^self]. (Smalltalk bindingOf: input) ifNotNil:[:assoc| | global | "It's a global or a class" global := assoc value. ^ToolSet browse: (global isBehavior ifTrue:[global] ifFalse:[global class]) selector: nil. ]. (SystemNavigation new allImplementorsOf: input asSymbol) ifNotEmpty:[:list| ^SystemNavigation new browseMessageList: list name: 'Implementors of ' , input ]. input first isUppercase ifTrue:[ (UIManager default classFromPattern: input withCaption: '') ifNotNil:[:aClass| ^ToolSet browse: aClass selector: nil. ]. ] ifFalse:[ ^ToolSet default browseMessageNames: input ]. newContents := input, ' -- not found.'. self newContents: newContents; selectFrom: input size+1 to: newContents size. evt hand newKeyboardFocus: self! ----- Method: CodeHolder>>abbreviatedWordingFor: (in category '*46Deprecated') ----- abbreviatedWordingFor: aButtonSelector "Answer the abbreviated form of wording, from a static table. Answer nil if there is no entry -- in which case the long form will be used on the corresponding browser button." #( (browseMethodFull 'browse') (browseSendersOfMessages 'senders') (browseMessages 'impl') (browseVersions 'vers') (methodHierarchy 'inher') (classHierarchy 'hier') (browseVariableReferences 'refs') (offerMenu 'menu')) do: [:pair | pair first == aButtonSelector ifTrue: [^ pair second]]. ^ nil! ----- Method: CodeHolder>>showingDiffsString (in category '*46Deprecated') ----- 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'! ----- Method: CodeHolder>>toggleDiff (in category '*46Deprecated') ----- toggleDiff "Retained for backward compatibility with existing buttons in existing images" self toggleDiffing! ----- Method: Browser>>classComment:notifying: (in category '*46Deprecated') ----- 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 comment: aText stamp: Utilities changeStamp]. self changed: #classCommentText. ^ true! ----- Method: Browser>>defineMessage:notifying: (in category '*46Deprecated') ----- defineMessage: aString notifying: aController self deprecated: 'Use Browser >> #defineMessageFrom:notifying:. This returns a Symbol or nil, not a Boolean.'. ^ (self defineMessageFrom: aString notifying: aController) notNil.! ----- Method: Browser>>messageListSingleton (in category '*46Deprecated') ----- messageListSingleton | name | name := self selectedMessageName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ----- Method: Browser>>optionalAnnotationHeight (in category '*46Deprecated') ----- optionalAnnotationHeight ^ 10! ----- Method: Browser>>optionalButtonHeight (in category '*46Deprecated') ----- optionalButtonHeight ^ 10! ----- Method: Browser>>potentialClassNames (in category '*46Deprecated') ----- potentialClassNames "Answer the names of all the classes that could be viewed in this browser. This hook is provided so that HierarchyBrowsers can indicate their restricted subset. For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers." ^ Smalltalk classNames! From commits at source.squeak.org Fri Jun 5 20:12:54 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:12:59 2015 Subject: [squeak-dev] Squeak 4.6: NetworkTests-fbs.37.mcz Message-ID: Chris Muller uploaded a new version of NetworkTests to project Squeak 4.6: http://source.squeak.org/squeak46/NetworkTests-fbs.37.mcz ==================== Summary ==================== Name: NetworkTests-fbs.37 Author: fbs Time: 6 November 2013, 6:35:55.414 pm UUID: 97699685-5826-fe47-af98-356971abf2fb Ancestors: NetworkTests-fbs.36 More #shouldnt:raise: Error fixes. ==================== Snapshot ==================== SystemOrganization addCategory: #'NetworkTests-Kernel'! SystemOrganization addCategory: #'NetworkTests-Protocols'! SystemOrganization addCategory: #'NetworkTests-RFC822'! SystemOrganization addCategory: #'NetworkTests-URI'! SystemOrganization addCategory: #'NetworkTests-UUID'! SystemOrganization addCategory: #'NetworkTests-Url'! Stream subclass: #MockSocketStream instanceVariableNames: 'atEnd inStream outStream' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! ----- Method: MockSocketStream class>>on: (in category 'instance creation') ----- on: socket ^self basicNew initialize! ----- Method: MockSocketStream>>atEnd (in category 'testing') ----- atEnd ^self inStream atEnd.! ----- Method: MockSocketStream>>atEnd: (in category 'accessing') ----- atEnd: aBoolean atEnd := aBoolean.! ----- Method: MockSocketStream>>inStream (in category 'accessing') ----- inStream ^inStream! ----- Method: MockSocketStream>>initialize (in category 'initialize-release') ----- initialize self resetInStream. self resetOutStream.! ----- Method: MockSocketStream>>nextLine (in category 'stream in') ----- nextLine ^self nextLineCrLf! ----- Method: MockSocketStream>>nextLineCrLf (in category 'stream in') ----- nextLineCrLf ^(self upToAll: String crlf).! ----- Method: MockSocketStream>>outStream (in category 'accessing') ----- outStream ^outStream! ----- Method: MockSocketStream>>resetInStream (in category 'stream in') ----- resetInStream inStream := WriteStream on: ''.! ----- Method: MockSocketStream>>resetOutStream (in category 'stream out') ----- resetOutStream outStream := WriteStream on: ''.! ----- Method: MockSocketStream>>sendCommand: (in category 'stream out') ----- sendCommand: aString self outStream nextPutAll: aString; nextPutAll: String crlf.! ----- Method: MockSocketStream>>upToAll: (in category 'stream in') ----- upToAll: delims ^self inStream upToAll: delims.! TestCase subclass: #MailAddressParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-RFC822'! !MailAddressParserTest commentStamp: '' 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! ----- Method: MailAddressParserTest>>testAddressesIn (in category 'tests') ----- testAddressesIn | testString correctAnswer | testString := 'joe@lama.com, joe2@lama.com joe3@lama.com joe4 , Not an 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 , foo+bar@baz.com'. 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' 'foo+bar@baz.com') asOrderedCollection. self assert: ((MailAddressParser addressesIn: testString) = correctAnswer).! TestCase subclass: #MailMessageTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-RFC822'! !MailMessageTest commentStamp: 'tonyg 9/12/2011 09:17' prior: 0! This is the unit test for the class MailMessage.! ----- Method: MailMessageTest>>testDateStampFractionalSecondFormatting (in category 'as yet unclassified') ----- testDateStampFractionalSecondFormatting self assert: (MailMessage dateStamp: (DateAndTime fromSeconds: 1.234)) = 'Tue, 1 Jan 1901 00:00:01' description: 'RFC822 (and RFC2822) forbids non-integer seconds in dates'! TestCase subclass: #SMTPClientTest instanceVariableNames: 'smtp socket' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Protocols'! ----- Method: SMTPClientTest>>setUp (in category 'running') ----- setUp socket := MockSocketStream on: ''. smtp := SMTPClient new. smtp stream: socket.! ----- Method: SMTPClientTest>>testMailFrom (in category 'testing') ----- testMailFrom smtp mailFrom: 'frank@angband.za.org'. self assert: socket outStream contents = ('MAIL FROM: ', String crlf). socket resetOutStream. smtp mailFrom: ''. self assert: socket outStream contents = ('MAIL FROM: ', String crlf). socket resetOutStream. smtp mailFrom: 'Frank '. self assert: socket outStream contents = ('MAIL FROM: ', String crlf).! TestCase subclass: #SocketTest instanceVariableNames: 'listenerSocket clientSocket serverSocket' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! ----- Method: SocketTest>>listenerAddress (in category 'setup') ----- listenerAddress ^NetNameResolver localHostAddress ! ----- Method: SocketTest>>listenerPort (in category 'setup') ----- listenerPort ^42324 ! ----- Method: SocketTest>>setUp (in category 'setup') ----- setUp listenerSocket := Socket newTCP listenOn: self listenerPort backlogSize: 4 interface: self listenerAddress. ! ----- Method: SocketTest>>tearDown (in category 'setup') ----- tearDown listenerSocket ifNotNil:[listenerSocket destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. ! ----- Method: SocketTest>>testClientConnect (in category 'tests') ----- testClientConnect "Tests a client socket connection" clientSocket := Socket newTCP. clientSocket connectTo: self listenerAddress port: self listenerPort. clientSocket waitForConnectionFor: 2. self assert: clientSocket isConnected. ! ----- Method: SocketTest>>testDataReceive (in category 'tests') ----- testDataReceive "Test data transfer and related methods" self testDataSending. "It can take a tad for the status change to be visible" (Delay forMilliseconds: 200) wait. self assert: serverSocket dataAvailable. self assert: (serverSocket receiveData = 'Hello World'). self deny: (serverSocket dataAvailable). ! ----- Method: SocketTest>>testDataSending (in category 'tests') ----- testDataSending "Test data transfer and related methods" self testServerAccept. clientSocket sendData: 'Hello World'. clientSocket waitForSendDoneFor: 2. self assert: clientSocket sendDone. ! ----- Method: SocketTest>>testLocalAddress (in category 'tests') ----- testLocalAddress "Tests the various localAddress values for sockets" self testServerAccept. self assert: listenerSocket localAddress = self listenerAddress. self assert: clientSocket localAddress = self listenerAddress. self assert: serverSocket localAddress = self listenerAddress. ! ----- Method: SocketTest>>testLocalPort (in category 'tests') ----- testLocalPort "Tests the various localPort values for sockets" self testServerAccept. self assert: listenerSocket localPort = self listenerPort. self assert: clientSocket localPort > 0. self assert: serverSocket localPort > 0. ! ----- Method: SocketTest>>testPeerName (in category 'tests') ----- testPeerName "None of these should throw an exception." Socket new peerName. self testServerAccept. listenerSocket peerName. clientSocket peerName. serverSocket peerName.! ----- Method: SocketTest>>testReceiveTimeout (in category 'tests') ----- testReceiveTimeout "Test data transfer and related methods" self testServerAccept. self assert: (serverSocket receiveDataTimeout: 1) isEmpty.! ----- Method: SocketTest>>testRemoteAddress (in category 'tests') ----- testRemoteAddress "Tests the various remoteAddress values for sockets" self testServerAccept. self assert: listenerSocket remoteAddress asByteArray = #[0 0 0 0]. self assert: clientSocket remoteAddress = self listenerAddress. self assert: serverSocket remoteAddress = self listenerAddress. ! ----- Method: SocketTest>>testRemotePort (in category 'tests') ----- testRemotePort "Tests the various remoteAddress values for sockets" self testServerAccept. self assert: listenerSocket remotePort = 0. self assert: clientSocket remotePort = self listenerPort. self assert: serverSocket remotePort > 0. ! ----- Method: SocketTest>>testSendTimeout (in category 'tests') ----- testSendTimeout "Test data transfer and related methods" | buffer ex | self testServerAccept. buffer := ByteArray new: 1000. "Write to the socket until the platform reports that sending is not complete." [serverSocket sendDone] whileTrue:[ serverSocket sendSomeData: buffer. ]. "The network layer is now either blocked or in the process of sending data in its buffers. It may or may not be able buffer additional write requests, depending on the platform implemention. Keep sending data until the network reports that it is unable to process the request, at which time a exception will be raised. On Windows, the exception will be raised on the next write request, while unix platforms may provide additional buffering that permit write requests to continue being accepted." ex := nil. [[serverSocket sendSomeData: buffer startIndex: 1 count: buffer size for: 1] on: ConnectionTimedOut do: [ :e | ex := e ]. ex isNil] whileTrue: []. self assert: ex notNil. ! ----- Method: SocketTest>>testServerAccept (in category 'tests') ----- testServerAccept "Tests a server-side accept" self testClientConnect. serverSocket := listenerSocket waitForAcceptFor: 2. self assert: (serverSocket notNil). self assert: (serverSocket isConnected). ! ----- Method: SocketTest>>testSocketReuse (in category 'tests') ----- testSocketReuse "Test for SO_REUSEADDR/SO_REUSEPORT" | address port udp1 send1 udp2 recv2 sendProc recvProc received | address := #[255 255 255 255]. "broadcast" port := 31259. [ udp1 := Socket newUDP. udp1 setOption: 'SO_REUSEADDR' value: 1. udp1 setOption: 'SO_REUSEPORT' value: 1. udp1 setPort: port. udp1 setOption: 'SO_BROADCAST' value: 1. send1 := UUID new. udp2 := Socket newUDP. udp2 setOption: 'SO_REUSEADDR' value: 1. udp2 setOption: 'SO_REUSEPORT' value: 1. udp2 setPort: port. udp2 setOption: 'SO_BROADCAST' value: 1. recv2 := UUID new. received := 0. recvProc := [ [received < 16] whileTrue:[ received := received + (udp2 receiveDataInto: recv2 startingAt: received + 1). ] ] fork. sendProc := [ udp1 setPeer: address port: port. udp1 sendData: send1 count: 16. ] fork. (Delay forMilliseconds: 200) wait. self should: [recvProc isTerminated]. self should: [sendProc isTerminated]. self should: [send1 = recv2]. ] ensure:[ udp1 destroy. udp2 destroy. ]. ! ----- Method: SocketTest>>testStringFromAddress (in category 'tests') ----- testStringFromAddress "Addresses are represented by a ByteArray if NetNameResolver useOldNetwork is true, or by by SocketAddress otherwise. Ensure the #stringFromAddress: works in either case. Older versions of SocketPlugin in the VM do not provide support for SocketAddress, and ByteArray addresses are used in that case." | localAddress localAddressBytes localName1 localName2 | localAddress := NetNameResolver localHostAddress. "ByteArray or SocketAddress" localAddressBytes := localAddress asByteArray. localName1 := NetNameResolver stringFromAddress: localAddress. localName2 := NetNameResolver stringFromAddress: localAddressBytes. self assert: localName1 = localName2 ! ----- Method: SocketTest>>testUDP (in category 'tests') ----- testUDP "Test udp recv() and send() functionality" serverSocket := Socket newUDP. serverSocket setPort: 54321. clientSocket := Socket newUDP. clientSocket setPeer: NetNameResolver localHostAddress port: serverSocket port. clientSocket sendData: 'Hello World'. (Delay forMilliseconds: 200) wait. self assert: (serverSocket dataAvailable). self assert: (serverSocket receiveData = 'Hello World'). ! TestCase subclass: #TestURI instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-URI'! !TestURI commentStamp: 'mir 2/27/2002 14:42' prior: 0! Main comment stating the purpose of this class and relevant relationship to other classes. Some parsers allow the scheme name to be present in a relative URI if it is the same as the base URI scheme. This is considered to be a loophole in prior specifications of partial URI [RFC1630]. Its use should be avoided. http:g = http:g ; for validating parsers | http://a/b/c/g ; for backwards compatibility ! ----- Method: TestURI class>>generateAbnormalResolverTests (in category 'test generation') ----- generateAbnormalResolverTests "TestURI generateAbnormalResolverTests" | relURIString result method testPairs pair | testPairs := #( #('../../../g' 'http://a/../g' ) #('../../../../g' 'http://a/../../g' ) #('/./g' 'http://a/./g' ) #('/../g' 'http://a/../g' ) #('g.' 'http://a/b/c/g.' ) #('.g' 'http://a/b/c/.g' ) #('g..' 'http://a/b/c/g..' ) #('..g' 'http://a/b/c/..g' ) #('./../g' 'http://a/b/g' ) #('./g/.' 'http://a/b/c/g/' ) #('g/./h' 'http://a/b/c/g/h' ) #('g/../h' 'http://a/b/c/h' ) #('g;x=1/./y' 'http://a/b/c/g;x=1/y' ) #('g;x=1/../y' 'http://a/b/c/y' ) #('g?y/./x' 'http://a/b/c/g?y/./x' ) #('g?y/../x' 'http://a/b/c/g?y/../x' ) #('g#s/./x' 'http://a/b/c/g#s/./x' ) #('g#s/../x' 'http://a/b/c/g#s/../x' ) ). 1 to: testPairs size do: [:index | pair := testPairs at: index. relURIString := pair first. result := pair last. method := String streamContents: [:stream | stream nextPutAll: 'testResolveAbnormal' , index printString; cr. stream nextPutAll: ' | baseURI relURI resolvedURI |' ; cr; nextPutAll: ' baseURI := ''http://a/b/c/d;p?q'' asURI.' ; cr; nextPutAll: ' relURI := '; nextPut: $'; nextPutAll: relURIString; nextPutAll: '''.' ; cr; nextPutAll: ' resolvedURI := baseURI resolveRelativeURI: relURI.' ; cr; nextPutAll: ' self should: [resolvedURI asString = '''; nextPutAll: result; nextPutAll: '''].' ; cr]. self compile: method classified: 'running resolving']. ! ----- Method: TestURI class>>generateNormalResolverTests (in category 'test generation') ----- generateNormalResolverTests "TestURI generateNormalResolverTests" | relURIString result method testPairs pair | testPairs := #( #('g:h' 'g:h' ) #('g' 'http://a/b/c/g' ) #('./g' 'http://a/b/c/g' ) #('g/' 'http://a/b/c/g/' ) #('/g' 'http://a/g' ) #('//g' 'http://g' ) #('?y' 'http://a/b/c/?y' ) #('g?y' 'http://a/b/c/g?y' ) #('g#s' 'http://a/b/c/g#s' ) #('g?y#s' 'http://a/b/c/g?y#s' ) #(';x' 'http://a/b/c/;x' ) #('g;x' 'http://a/b/c/g;x' ) #('g;x?y#s' 'http://a/b/c/g;x?y#s' ) #('.' 'http://a/b/c/' ) #('./' 'http://a/b/c/' ) #('..' 'http://a/b/' ) #('../' 'http://a/b/' ) #('../g' 'http://a/b/g' ) #('../..' 'http://a/' ) #('../../' 'http://a/' ) #('../../g' 'http://a/g' ) ). 1 to: testPairs size do: [:index | pair := testPairs at: index. relURIString := pair first. result := pair last. method := String streamContents: [:stream | stream nextPutAll: 'testResolveNormal' , index printString; cr. stream nextPutAll: ' | baseURI relURI resolvedURI |' ; cr; nextPutAll: ' baseURI := ''http://a/b/c/d;p?q'' asURI.' ; cr; nextPutAll: ' relURI := '; nextPut: $'; nextPutAll: relURIString; nextPutAll: '''.' ; cr; nextPutAll: ' resolvedURI := baseURI resolveRelativeURI: relURI.' ; cr; nextPutAll: ' self should: [resolvedURI asString = '''; nextPutAll: result; nextPutAll: '''].' ; cr]. self compile: method classified: 'running resolving']. ! ----- Method: TestURI>>testDefaultDirRoundtrip (in category 'running file') ----- testDefaultDirRoundtrip | defaultDir defaultURI uriDir | defaultDir := FileDirectory default. defaultURI := defaultDir uri. uriDir := FileDirectory uri: defaultURI. self should: [defaultDir fullName = uriDir fullName]! ----- Method: TestURI>>testDirWithHash (in category 'running file') ----- testDirWithHash "Tests proper escaping of directories with hash mark" | uriDir origPath origDir dirURI | origPath := FileDirectory default pathName, '#123'. origDir := FileDirectory on: origPath. self assert: origDir pathName = origPath. dirURI := origDir uri. uriDir := FileDirectory uri: dirURI. self assert: origDir fullName = uriDir fullName.! ----- Method: TestURI>>testDirectoryRoot (in category 'running file') ----- testDirectoryRoot | rootDir uriRoot uriDir | rootDir := FileDirectory root. uriRoot := 'file:///' asURI. uriDir := FileDirectory uri: uriRoot. self should: [rootDir fullName = uriDir fullName]! ----- Method: TestURI>>testResolveAbnormal1 (in category 'running resolving') ----- testResolveAbnormal1 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../../../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/../g']. ! ----- Method: TestURI>>testResolveAbnormal10 (in category 'running resolving') ----- testResolveAbnormal10 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := './g/.'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g/']. ! ----- Method: TestURI>>testResolveAbnormal11 (in category 'running resolving') ----- testResolveAbnormal11 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g/./h'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g/h']. ! ----- Method: TestURI>>testResolveAbnormal12 (in category 'running resolving') ----- testResolveAbnormal12 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g/../h'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/h']. ! ----- Method: TestURI>>testResolveAbnormal13 (in category 'running resolving') ----- testResolveAbnormal13 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g;x=1/./y'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g;x=1/y']. ! ----- Method: TestURI>>testResolveAbnormal14 (in category 'running resolving') ----- testResolveAbnormal14 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g;x=1/../y'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/y']. ! ----- Method: TestURI>>testResolveAbnormal15 (in category 'running resolving') ----- testResolveAbnormal15 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g?y/./x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g?y/./x']. ! ----- Method: TestURI>>testResolveAbnormal16 (in category 'running resolving') ----- testResolveAbnormal16 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g?y/../x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g?y/../x']. ! ----- Method: TestURI>>testResolveAbnormal17 (in category 'running resolving') ----- testResolveAbnormal17 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g#s/./x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g#s/./x']. ! ----- Method: TestURI>>testResolveAbnormal18 (in category 'running resolving') ----- testResolveAbnormal18 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g#s/../x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g#s/../x']. ! ----- Method: TestURI>>testResolveAbnormal2 (in category 'running resolving') ----- testResolveAbnormal2 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../../../../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/../../g']. ! ----- Method: TestURI>>testResolveAbnormal3 (in category 'running resolving') ----- testResolveAbnormal3 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '/./g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/./g']. ! ----- Method: TestURI>>testResolveAbnormal4 (in category 'running resolving') ----- testResolveAbnormal4 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '/../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/../g']. ! ----- Method: TestURI>>testResolveAbnormal5 (in category 'running resolving') ----- testResolveAbnormal5 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g.'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g.']. ! ----- Method: TestURI>>testResolveAbnormal6 (in category 'running resolving') ----- testResolveAbnormal6 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '.g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/.g']. ! ----- Method: TestURI>>testResolveAbnormal7 (in category 'running resolving') ----- testResolveAbnormal7 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g..'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g..']. ! ----- Method: TestURI>>testResolveAbnormal8 (in category 'running resolving') ----- testResolveAbnormal8 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '..g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/..g']. ! ----- Method: TestURI>>testResolveAbnormal9 (in category 'running resolving') ----- testResolveAbnormal9 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := './../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/g']. ! ----- Method: TestURI>>testResolveNormal1 (in category 'running resolving') ----- testResolveNormal1 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g:h'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'g:h']. ! ----- Method: TestURI>>testResolveNormal10 (in category 'running resolving') ----- testResolveNormal10 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g?y#s'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g?y#s']. ! ----- Method: TestURI>>testResolveNormal11 (in category 'running resolving') ----- testResolveNormal11 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := ';x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/;x']. ! ----- Method: TestURI>>testResolveNormal12 (in category 'running resolving') ----- testResolveNormal12 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g;x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g;x']. ! ----- Method: TestURI>>testResolveNormal13 (in category 'running resolving') ----- testResolveNormal13 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g;x?y#s'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g;x?y#s']. ! ----- Method: TestURI>>testResolveNormal14 (in category 'running resolving') ----- testResolveNormal14 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '.'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/']. ! ----- Method: TestURI>>testResolveNormal15 (in category 'running resolving') ----- testResolveNormal15 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := './'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/']. ! ----- Method: TestURI>>testResolveNormal16 (in category 'running resolving') ----- testResolveNormal16 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '..'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/']. ! ----- Method: TestURI>>testResolveNormal17 (in category 'running resolving') ----- testResolveNormal17 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/']. ! ----- Method: TestURI>>testResolveNormal18 (in category 'running resolving') ----- testResolveNormal18 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/g']. ! ----- Method: TestURI>>testResolveNormal19 (in category 'running resolving') ----- testResolveNormal19 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../..'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/']. ! ----- Method: TestURI>>testResolveNormal2 (in category 'running resolving') ----- testResolveNormal2 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g']. ! ----- Method: TestURI>>testResolveNormal20 (in category 'running resolving') ----- testResolveNormal20 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../../'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/']. ! ----- Method: TestURI>>testResolveNormal21 (in category 'running resolving') ----- testResolveNormal21 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/g']. ! ----- Method: TestURI>>testResolveNormal3 (in category 'running resolving') ----- testResolveNormal3 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := './g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g']. ! ----- Method: TestURI>>testResolveNormal4 (in category 'running resolving') ----- testResolveNormal4 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g/'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g/']. ! ----- Method: TestURI>>testResolveNormal5 (in category 'running resolving') ----- testResolveNormal5 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '/g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/g']. ! ----- Method: TestURI>>testResolveNormal6 (in category 'running resolving') ----- testResolveNormal6 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '//g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://g']. ! ----- Method: TestURI>>testResolveNormal7 (in category 'running resolving') ----- testResolveNormal7 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '?y'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/?y']. ! ----- Method: TestURI>>testResolveNormal8 (in category 'running resolving') ----- testResolveNormal8 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g?y'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g?y']. ! ----- Method: TestURI>>testResolveNormal9 (in category 'running resolving') ----- testResolveNormal9 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g#s'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g#s']. ! ----- Method: TestURI>>testSchemeAbsoluteFail1 (in category 'running parsing') ----- testSchemeAbsoluteFail1 self should: [URI fromString: 'http:'] raise: IllegalURIException! ----- Method: TestURI>>testSchemeAbsolutePass1 (in category 'running parsing') ----- testSchemeAbsolutePass1 | uri | uri := URI fromString: 'http://www.squeakland.org'. self should: [uri scheme = 'http']. self should: [uri isAbsolute]. self shouldnt: [uri isOpaque]. self shouldnt: [uri isRelative]! ----- Method: TestURI>>testSchemeAbsolutePass2 (in category 'running parsing') ----- testSchemeAbsolutePass2 | uri | uri := URI fromString: 'mailto:somebody@somewhere.nowhere'. self should: [uri scheme = 'mailto']. self should: [uri isAbsolute]. self should: [uri isOpaque]. self shouldnt: [uri isRelative]! ----- Method: TestURI>>testSchemeAbsolutePass3 (in category 'running parsing') ----- testSchemeAbsolutePass3 | uri | uri := URI fromString: 'ftp://ftp@squeak.org'. self should: [uri scheme = 'ftp']. self should: [uri isAbsolute]. self shouldnt: [uri isOpaque]. self shouldnt: [uri isRelative]. self should: [uri userInfo = 'ftp']. self should: [uri host = 'squeak.org']. self should: [uri port isNil]. ! ----- Method: TestURI>>testSchemeAbsolutePass4 (in category 'running parsing') ----- testSchemeAbsolutePass4 | uri | uri := URI fromString: 'mailto:somebody@somewhere.nowhere#fragment'. self should: [uri scheme = 'mailto']. self should: [uri isAbsolute]. self should: [uri isOpaque]. self shouldnt: [uri isRelative]. self should: [uri fragment = 'fragment']. ! ----- Method: TestURI>>testSchemeAbsolutePass5 (in category 'running parsing') ----- testSchemeAbsolutePass5 | uri | uri := URI fromString: 'http://www.squeakland.org#fragment'. self should: [uri scheme = 'http']. self should: [uri isAbsolute]. self shouldnt: [uri isOpaque]. self shouldnt: [uri isRelative]. self should: [uri fragment = 'fragment']. ! TestCase subclass: #UUIDPrimitivesTest instanceVariableNames: '' classVariableNames: 'Default' poolDictionaries: '' category: 'NetworkTests-UUID'! ----- Method: UUIDPrimitivesTest>>testCreation (in category 'tests') ----- testCreation | uuid | uuid := UUID new. self should: [uuid size = 16]. self shouldnt: [uuid isNilUUID]. self should: [uuid asString size = 36]. ! ----- Method: UUIDPrimitivesTest>>testCreationEquality (in category 'tests') ----- testCreationEquality | uuid1 uuid2 | uuid1 := UUID new. uuid2 := UUID new. self should: [uuid1 = uuid1]. self should: [uuid2 = uuid2]. self shouldnt: [uuid1 = uuid2]. self shouldnt: [uuid1 hash = uuid2 hash]. ! ----- Method: UUIDPrimitivesTest>>testCreationFromString (in category 'tests') ----- testCreationFromString | uuid string | string := UUID nilUUID asString. uuid := UUID fromString: string. self should: [uuid size = 16]. self should: [uuid = UUID nilUUID]. self should: [uuid isNilUUID]. self should: [uuid asString size = 36]. self should: [uuid asArray asSet size = 1]. self should: [(uuid asArray asSet asArray at: 1) = 0]. ! ----- Method: UUIDPrimitivesTest>>testCreationFromStringNotNil (in category 'tests') ----- testCreationFromStringNotNil | uuid string | string := UUID new asString. uuid := UUID fromString: string. self should: [uuid size = 16]. self should: [uuid asString size = 36]. ! ----- Method: UUIDPrimitivesTest>>testCreationNil (in category 'tests') ----- testCreationNil | uuid | uuid := UUID nilUUID. self should: [uuid size = 16]. self should: [uuid isNilUUID]. self should: [uuid asString size = 36]. self should: [uuid asArray asSet size = 1]. self should: [(uuid asArray asSet asArray at: 1) = 0]. ! ----- Method: UUIDPrimitivesTest>>testCreationNodeBased (in category 'tests') ----- testCreationNodeBased (UUID new asString last: 12) = (UUID new asString last: 12) ifFalse: [^self]. 1000 timesRepeat: [ | uuid | uuid := UUID new. self should: [((uuid at: 7) bitAnd: 16rF0) = 16r10]. self should: [((uuid at: 9) bitAnd: 16rC0) = 16r80]] ! ----- Method: UUIDPrimitivesTest>>testDuplicationsKinda (in category 'tests') ----- testDuplicationsKinda | check size | size := 5000. check := Set new: size. size timesRepeat: [ | uuid | uuid := UUID new. self shouldnt: [check includes: uuid]. check add: uuid]. ! ----- Method: UUIDPrimitivesTest>>testOrder (in category 'tests') ----- testOrder 100 timesRepeat: [ | uuid1 uuid2 | uuid1 := UUID new. uuid2 := UUID new. (uuid1 asString last: 12) = (uuid2 asString last: 12) ifTrue: [self should: [uuid1 < uuid2]. self should: [uuid2 > uuid1]. self shouldnt: [uuid1 = uuid2]]] ! TestCase subclass: #UUIDTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-UUID'! ----- Method: UUIDTest>>testComparison (in category 'as yet unclassified') ----- testComparison "Test if the comparison operators define a total sort function." #( #[3 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0] #[2 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 1] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4] #[2 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0] #[3 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 2 4] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 1] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4] ) pairsDo: [ :x :y | | a b c d | a := UUID newFrom: x. b := UUID newFrom: y. c := x asString. d := y asString. "Check if the comparison is lexicographical, just like strings'." #(< > <= >= = ~=) do: [ :operation | self assert: (a perform: operation with: b) = (c perform: operation with: d) ]. "And a few more" self assert: (a < b) = (a >= b) not; assert: (a > b) = (a <= b) not; assert: (a = b) = (a ~= b) not; assert: (a < b) = (b > a); assert: (a > b) = (b < a); assert: (a >= b) = (b <= a); assert: (a <= b) = (b >= a); assert: (a = b) = (b = a); assert: (a ~= b) = (b ~= a); assert: (a > b) = ((a >= b) & (a ~= b)); assert: (a < b) = ((a <= b) & (a ~= b)); assert: (a >= b) = ((a = b) | (a > b)); assert: (a <= b) = ((a = b) | (a < b)); assert: (a ~= b) = ((a < b) | (a > b)); assert: (a <= b) & (b <= a) = (a = b); assert: (a >= b) & (b >= a) = (a = b); assert: (a <= b) | (b <= a); assert: (a = b) asBit + (a < b) asBit + (b < a) asBit = 1 ]! ClassTestCase subclass: #FileUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! ----- Method: FileUrlTest>>testAsString (in category 'testing') ----- testAsString | target url | target := 'file://localhost/etc/rc.conf'. url := target asUrl. self assert: url asString = target. ! ClassTestCase subclass: #GenericUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! ----- Method: GenericUrlTest>>testAsString (in category 'testing') ----- testAsString | url | url := GenericUrl new schemeName: 'sip' locator: 'foo@bar'. self assert: url asString = 'sip:foo@bar'.! ClassTestCase subclass: #HierarchicalUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! ----- Method: HierarchicalUrlTest>>testAsString (in category 'testing') ----- testAsString | url | url := HierarchicalUrl new schemeName: 'ftp' authority: 'localhost' path: #('path' 'to' 'file') query: 'aQuery'. self assert: url asString = 'ftp://localhost/path/to/file?aQuery'.! ClassTestCase subclass: #HttpUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! ----- Method: HttpUrlTest>>testHttps (in category 'as yet unclassified') ----- testHttps self assert: 'https://encrypted.google.com' asUrl class == HttpUrl! ClassTestCase subclass: #SocketStreamTest instanceVariableNames: 'clientStream serverStream' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! ----- Method: SocketStreamTest>>setUp (in category 'setup') ----- setUp | listener clientSocket serverSocket | listener := Socket newTCP. [listener listenOn: 0 backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: listener localPort. clientSocket waitForConnectionFor: 1. self assert: clientSocket isConnected. serverSocket := listener waitForAcceptFor: 1. self assert: serverSocket isConnected. ] ensure:[listener destroy]. clientStream := SocketStream on: clientSocket. serverStream := SocketStream on: serverSocket. ! ----- Method: SocketStreamTest>>tearDown (in category 'setup') ----- tearDown clientStream ifNotNil:[clientStream destroy]. serverStream ifNotNil:[serverStream destroy].! ----- Method: SocketStreamTest>>testNextIntoClose (in category 'stream protocol') ----- testNextIntoClose "Ensure that #next:into: will function properly when the connection is closed" clientStream nextPutAll:'A line of text'; flush. [(Delay forMilliseconds: 100) wait. clientStream close] fork. self assert: (serverStream next: 100 into: (String new: 100) startingAt: 1) equals: 'A line of text'. ! ----- Method: SocketStreamTest>>testNextIntoCloseNonSignaling (in category 'stream protocol') ----- testNextIntoCloseNonSignaling "Ensure that #next:into: will function properly when the connection is closed" serverStream shouldSignal: false. clientStream nextPutAll:'A line of text'; flush. [(Delay forMilliseconds: 100) wait. clientStream close] fork. self assert: (serverStream next: 100 into: (String new: 100) startingAt: 1) equals: 'A line of text'. ! ----- Method: SocketStreamTest>>testUpTo (in category 'stream protocol') ----- testUpTo "Tests correct behavior of #upTo:" clientStream nextPutAll:'A line of text', String cr, 'with more text'; flush. self assert: (serverStream upTo: Character cr) = 'A line of text'. [(Delay forSeconds: 1) wait. clientStream nextPutAll: String cr; flush] fork. self assert: (serverStream upTo: Character cr) = 'with more text'. ! ----- Method: SocketStreamTest>>testUpToAfterCloseNonSignaling (in category 'stream protocol') ----- testUpToAfterCloseNonSignaling "Tests correct behavior of #upToAll" | resp | clientStream nextPutAll: 'A line of text'. clientStream close. serverStream shouldSignal: false. self shouldnt: [resp := serverStream upTo: Character cr] raise: ConnectionClosed. self assert: resp = 'A line of text'.! ----- Method: SocketStreamTest>>testUpToAfterCloseSignaling (in category 'stream protocol') ----- testUpToAfterCloseSignaling "Tests correct behavior of #upToAll" clientStream nextPutAll:'A line of text'. clientStream close. self should: [serverStream upTo: Character cr] raise: ConnectionClosed. ! ----- Method: SocketStreamTest>>testUpToAll (in category 'stream protocol') ----- testUpToAll "Tests correct behavior of #upToAll" clientStream nextPutAll:'A line of text', String crlf, 'with more text'; flush. self assert: (serverStream upToAll: String crlf) = 'A line of text'. [(Delay forSeconds: 1) wait. clientStream nextPutAll: String crlf; flush] fork. self assert: (serverStream upToAll: String crlf) = 'with more text'. ! ----- Method: SocketStreamTest>>testUpToAllAfterCloseNonSignaling (in category 'stream protocol') ----- testUpToAllAfterCloseNonSignaling "Tests correct behavior of #upToAll" | resp | clientStream nextPutAll: 'A line of text'. clientStream close. serverStream shouldSignal: false. self shouldnt: [resp := serverStream upToAll: String crlf] raise: ConnectionClosed. self assert: resp = 'A line of text'.! ----- Method: SocketStreamTest>>testUpToAllAfterCloseSignaling (in category 'stream protocol') ----- testUpToAllAfterCloseSignaling "Tests correct behavior of #upToAll" clientStream nextPutAll:'A line of text'. clientStream close. self should: [serverStream upToAll: String crlf] raise: ConnectionClosed. ! ----- Method: SocketStreamTest>>testUpToAllAsciiVsBinary (in category 'stream protocol') ----- testUpToAllAsciiVsBinary "Tests correct behavior of #upToAll" serverStream ascii. clientStream nextPutAll:'A line of text', String crlf, 'with more text'; flush. self assert: (serverStream upToAll: #[13 10]) = 'A line of text'. serverStream binary. clientStream nextPutAll: String crlf; flush. self assert: (serverStream upToAll: String crlf) asString = 'with more text'. ! ----- Method: SocketStreamTest>>testUpToAllLimit (in category 'stream protocol') ----- testUpToAllLimit "Tests correct behavior of #upToAll:limit:" clientStream nextPutAll:'A line of text'; flush. self assert: (serverStream upToAll: String crlf limit: 5) = 'A line of text'.! ----- Method: SocketStreamTest>>testUpToAllTimeout (in category 'stream protocol') ----- testUpToAllTimeout "Tests correct behavior of #upToAll" clientStream nextPutAll: 'A line of text'. serverStream timeout: 1. self should: [serverStream upToAll: String crlf] raise: ConnectionTimedOut. ! ----- Method: SocketStreamTest>>testUpToAsciiVsBinary (in category 'stream protocol') ----- testUpToAsciiVsBinary "Tests correct behavior of #upTo:" serverStream ascii. clientStream nextPutAll:'A line of text', String cr, 'with more text'; flush. self assert: (serverStream upTo: 13) = 'A line of text'. serverStream binary. clientStream nextPutAll: String cr; flush. self assert: (serverStream upTo: Character cr) asString = 'with more text'. ! ----- Method: SocketStreamTest>>testUpToEndClose (in category 'stream protocol') ----- testUpToEndClose "Ensure that #upToEnd will function properly when the connection is closed" clientStream nextPutAll:'A line of text'; flush. [(Delay forMilliseconds: 100) wait. clientStream close] fork. self assert: (serverStream upToEnd) equals: 'A line of text'. ! ----- Method: SocketStreamTest>>testUpToEndCloseNonSignaling (in category 'stream protocol') ----- testUpToEndCloseNonSignaling "Ensure that #upToEnd will function properly when the connection is closed" serverStream shouldSignal: false. clientStream nextPutAll:'A line of text'; flush. [(Delay forMilliseconds: 100) wait. clientStream close] fork. self assert: (serverStream upToEnd) equals: 'A line of text'. ! ----- Method: SocketStreamTest>>testUpToMax (in category 'stream protocol') ----- testUpToMax "Tests correct behavior of #upToAll:max:" clientStream nextPutAll:'A line of text'; flush. self assert: (serverStream upTo: Character cr limit: 5) = 'A line of text'.! ----- Method: SocketStreamTest>>testUpToTimeout (in category 'stream protocol') ----- testUpToTimeout "Tests correct behavior of #upToAll" clientStream nextPutAll: 'A line of text'. serverStream timeout: 1. self should: [serverStream upTo: Character cr] raise: ConnectionTimedOut. ! ClassTestCase subclass: #UrlTest instanceVariableNames: 'url baseUrl expected string' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! !UrlTest commentStamp: '' prior: 0! This is the unit test for the class Url. 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! ----- Method: UrlTest>>testAbsoluteBrowser (in category 'tests') ----- testAbsoluteBrowser url := Url absoluteFromText: 'browser:bookmarks#mainPart'. self assert: url schemeName = 'browser'. self assert: url locator = 'bookmarks'. self assert:url fragment = 'mainPart'. self assert: url class = BrowserUrl. ! ----- Method: UrlTest>>testAbsoluteFILE (in category 'tests') ----- testAbsoluteFILE url := Url absoluteFromText: 'file:/etc/passwd#foo'. self assert: url schemeName = 'file'. self assert: url path first = 'etc'. self assert: url path size = 2. self assert: url fragment = 'foo'.! ----- Method: UrlTest>>testAbsoluteFILE2 (in category 'tests') ----- testAbsoluteFILE2 url := 'fILE:/foo/bar//zookie/?fakequery/#fragger' asUrl. self assert: url schemeName = 'file'. self assert: url class = FileUrl. self assert: url path first ='foo'. self assert: url path size = 5. self assert: url fragment = 'fragger'.! ----- Method: UrlTest>>testAbsoluteFILE3 (in category 'tests') ----- testAbsoluteFILE3 "Just a few selected tests for FileUrl, not complete by any means." {'file:'. 'file:/'. 'file://'} do: [:s | url := FileUrl absoluteFromText: s. self assert: (url asString = 'file:///'). self assert: (url host = ''). self assert: url isAbsolute]. url := FileUrl absoluteFromText: 'file://localhost/dir/file.txt'. self assert: (url asString = 'file://localhost/dir/file.txt'). self assert: (url host = 'localhost'). url := FileUrl absoluteFromText: 'file://localhost/dir/file.txt'. self assert: (url asString = 'file://localhost/dir/file.txt'). self assert: (url host = 'localhost'). self assert: url isAbsolute. url := FileUrl absoluteFromText: 'file:///dir/file.txt'. self assert: (url asString = 'file:///dir/file.txt'). self assert: (url host = ''). self assert: url isAbsolute. url := FileUrl absoluteFromText: '/dir/file.txt'. self assert: (url asString = 'file:///dir/file.txt'). self assert: url isAbsolute. url := FileUrl absoluteFromText: 'dir/file.txt'. self assert: (url asString = 'file:///dir/file.txt'). self deny: url isAbsolute. url := FileUrl absoluteFromText: 'c:/dir/file.txt'. self assert: (url asString = 'file:///c%3A/dir/file.txt'). self assert: url isAbsolute. "Only a drive letter doesn't refer to a directory." url := FileUrl absoluteFromText: 'c:'. self assert: (url asString = 'file:///c%3A/'). self assert: url isAbsolute. url := FileUrl absoluteFromText: 'c:/'. self assert: (url asString = 'file:///c%3A/'). self assert: url isAbsolute! ----- Method: UrlTest>>testAbsoluteFTP (in category 'tests') ----- testAbsoluteFTP url := 'ftP://some.server/some/directory/' asUrl. self assert: url schemeName = 'ftp'. self assert: url class = FtpUrl. self assert: url authority = 'some.server'. self assert: url path first = 'some'. self assert: url path size = 3. ! ----- Method: UrlTest>>testAbsoluteHTTP (in category 'tests') ----- testAbsoluteHTTP url := 'hTTp://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part' asUrl. self assert: url schemeName = 'http'. self assert: url authority = 'chaos.resnet.gatech.edu'. self assert: url path first = 'docs'. self assert: url path size = 3. self assert: url query = 'A%20query%20'. self assert: url fragment = 'part'.! ----- Method: UrlTest>>testAbsolutePortErrorFix (in category 'tests') ----- testAbsolutePortErrorFix "This should not throw an exception." Url absoluteFromText: 'http://swikis.ddo.jp:8823/'. self should: [Url absoluteFromText: 'http://swikis.ddo.jp:-1/'] raise: Error. self should: [Url absoluteFromText: 'http://swikis.ddo.jp:65536/'] raise: Error. self should: [Url absoluteFromText: 'http://swikis.ddo.jp:auau/'] raise: Error.! ----- Method: UrlTest>>testAbsoluteTELNET (in category 'tests') ----- testAbsoluteTELNET url := 'telNet:chaos.resnet.gatech.edu#goo' asUrl. self assert: url schemeName = 'telnet'. self assert: url locator = 'chaos.resnet.gatech.edu'. self assert: url fragment = 'goo'. ! ----- Method: UrlTest>>testCombineWithRelative (in category 'tests') ----- testCombineWithRelative #(#('http://www.rfc1149.net/' 'foo.html' 'http://www.rfc1149.net/foo.html') #('http://www.rfc1149.net/index.html' 'foo.html' 'http://www.rfc1149.net/foo.html') #('http://www.rfc1149.net/devel/' '../sam/' 'http://www.rfc1149.net/sam/') #('http://www.rfc1149.net/devel/index.html' '../sam/' 'http://www.rfc1149.net/sam/')) do: [:a | self assert: (Url combine: a first withRelative: a second) = a third]! ----- Method: UrlTest>>testFromFileNameOrUrlString (in category 'testing') ----- testFromFileNameOrUrlString url := Url absoluteFromFileNameOrUrlString: 'asdf'. self assert: url schemeName = 'file'. self assert: url fragment isNil. self assert: url class = FileUrl. url := Url absoluteFromFileNameOrUrlString: 'http://209.143.91.36/super/SuperSwikiProj/AAEmptyTest.001.pr'. self assert: url schemeName = 'http'. self assert: url fragment isNil. self assert: url class = HttpUrl.! ----- Method: UrlTest>>testRelativeFILE (in category 'tests') ----- testRelativeFILE | url2 | baseUrl := 'file:/some/dir#fragment1' asUrl. url := baseUrl newFromRelativeText: 'file:../another/dir/#fragment2'. self assert: url asText = 'file:///another/dir/#fragment2'. url := FileUrl absoluteFromText: 'file://localhost/dir/dir2/file.txt'. url2 := FileUrl absoluteFromText: 'file://hostname/flip/file.txt'. url2 privateInitializeFromText: '../file2.txt' relativeTo: url. self assert: (url2 asString = 'file://localhost/dir/file2.txt'). self assert: (url2 host = 'localhost'). self assert: url2 isAbsolute. url := FileUrl absoluteFromText: 'file://localhost/dir/dir2/file.txt'. url2 := FileUrl absoluteFromText: 'flip/file.txt'. self deny: url2 isAbsolute. url2 privateInitializeFromText: '.././flip/file.txt' relativeTo: url. self assert: (url2 asString = 'file://localhost/dir/flip/file.txt'). self assert: (url2 host = 'localhost'). self assert: url2 isAbsolute. ! ----- Method: UrlTest>>testRelativeFTP (in category 'tests') ----- testRelativeFTP baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. url := baseUrl newFromRelativeText: 'ftp://a.b'. self assert: url asString = 'ftp://a.b/'.! ----- Method: UrlTest>>testRelativeFTP2 (in category 'tests') ----- testRelativeFTP2 baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. url := baseUrl newFromRelativeText: 'ftp:xyz'. self assert: url asString = 'ftp://somewhere/some/dir/xyz'.! ----- Method: UrlTest>>testRelativeFTP3 (in category 'tests') ----- testRelativeFTP3 baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. url := baseUrl newFromRelativeText: 'http:xyz'. self assert: url asString = 'http://xyz/'.! ----- Method: UrlTest>>testRelativeHTTP (in category 'tests') ----- testRelativeHTTP baseUrl := 'http://some.where/some/dir?query1#fragment1' asUrl. url := baseUrl newFromRelativeText: '../another/dir/?query2#fragment2'. self assert: url asString = 'http://some.where/another/dir/?query2#fragment2'.! ----- Method: UrlTest>>testRoundTripFILE (in category 'tests') ----- testRoundTripFILE "File URLs should round-trip OK. This test should ultimately be tested on all platforms." | fileName | fileName := FileDirectory default fullNameFor: 'xxx.st'. url := FileDirectory urlForFileNamed: fileName. self assert: (url pathForFile = fileName) description: 'fileName didn''t round-trip'.! ----- Method: UrlTest>>testUrlEncoded (in category 'tests') ----- testUrlEncoded "Test the behavior of #urlEncoded" self assert: 'http://squeak.org/name with space?and=value' urlEncoded equals: 'http://squeak.org/name%20with%20space?and=value'. self assert: 'http://squeak.org/name%20with%20space?and=value' urlEncoded equals: 'http://squeak.org/name%20with%20space?and=value'. self assert: 'http://squeak.org/name%with%space?and=value' urlEncoded equals: 'http://squeak.org/name%25with%25space?and=value'. ! ----- Method: UrlTest>>testUsernamePassword (in category 'tests') ----- testUsernamePassword "basic case with a username+password specified" url := 'http://user:pword@someserver.blah:8000/root/index.html' asUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = 8000 ]. self should: [ url path first = 'root' ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "basic case for a relative url" baseUrl := 'http://anotherserver.blah:9999/somedir/someotherdir/stuff/' asUrl. url := 'http://user:pword@someserver.blah:8000/root/index.html' asUrlRelativeTo: baseUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = 8000 ]. self should: [ url path first = 'root' ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "a true relative test that should keep the username and password from the base URL" baseUrl := 'http://user:pword@someserver.blah:8000/root/index.html' asUrl. url := '/anotherdir/stuff/' asUrlRelativeTo: baseUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = 8000 ]. self should: [ url path first = 'anotherdir' ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "just a username specified" url := 'http://user@someserver.blah:8000/root/index.html' asUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = 8000 ]. self should: [ url path first = 'root' ]. self should: [ url username = 'user' ]. self should: [ url password = nil ]. "the port is not specified" url := 'http://user:pword@someserver.blah/root/index.html' asUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = nil ]. self should: [ url path first = 'root' ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "neither a path nor a port is specified" url := 'http://user:pword@someserver.blah' asUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = nil ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "relative URL where the username+password should be forgotten" baseUrl := 'http://user:pword@someserver.blah' asUrl. url := 'http://anotherserver.blah' asUrlRelativeTo: baseUrl. self should: [ url username = nil ]. self should: [ url password = nil ]. ! ----- Method: UrlTest>>testUsernamePasswordEncoded (in category 'tests') ----- testUsernamePasswordEncoded "Sometimes, weird usernames or passwords are necessary in applications, and, thus, we might receive them in a Url. The @ and the : ar the kind of critical ones. " #( "('user' 'pword' 'host' port 'path')" ('Fürst Pückler' 'leckerEis' 'cottbus.brandenburg' 80 'mein/Zuhause') ('Jeannde.d''Arc' 'jaiunesécret' 'orleans' 8080 'une/deux/trois') ('HaXor@roxor:fnac' 'my~Pa$§wert' 'cbase' 42 'do/not_try') ) do: [:urlParts | |theUrl| theUrl := ('http://{1}:{2}@{3}:{4}/{5}' format: { (urlParts at: 1) encodeForHTTP. (urlParts at: 2) encodeForHTTP. urlParts at: 3. urlParts at: 4. urlParts at: 5. }) asUrl. self should: [theUrl schemeName = 'http']; should: [theUrl username = (urlParts at: 1)]; should: [theUrl password = (urlParts at: 2)]; should: [theUrl authority = (urlParts at: 3)]; should: [theUrl port = (urlParts at: 4)]; should: [theUrl path first = ((urlParts at: 5) copyUpTo: $/)]]. ! ----- Method: UrlTest>>testUsernamePasswordPrinting (in category 'tests') ----- testUsernamePasswordPrinting #( 'http://user:pword@someserver.blah:8000/root/index.html' 'http://user@someserver.blah:8000/root/index.html' 'http://user:pword@someserver.blah/root/index.html' ) do: [ :urlText | self should: [ urlText = urlText asUrl asString ] ]. ! ----- Method: UrlTest>>testUsernamePasswordPrintingEncoded (in category 'tests') ----- testUsernamePasswordPrintingEncoded #( 'http://F%C3%BCrst%20P%C3%BCckler:leckerEis@cottbus.brandenburg:80/mein/Zuhause' 'http://Jeannde.d%27Arc:jaiunes%C3%A9cret@orleans:8080/une/deux/trois' 'http://HaXor%40roxor%3Afnac:my%7EPa%24%C2%A7wert@cbase:42/do/not_try' ) do: [ :urlText | self should: [ urlText = urlText asUrl asString ] ]. ! From commits at source.squeak.org Fri Jun 5 20:13:34 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:13:37 2015 Subject: [squeak-dev] Squeak 4.6: SystemChangeNotification-Tests-nice.23.mcz Message-ID: Chris Muller uploaded a new version of SystemChangeNotification-Tests to project Squeak 4.6: http://source.squeak.org/squeak46/SystemChangeNotification-Tests-nice.23.mcz ==================== Summary ==================== Name: SystemChangeNotification-Tests-nice.23 Author: nice Time: 18 December 2013, 2:43:23.729 pm UUID: 3eed6d26-4aef-4095-a604-d9f914240281 Ancestors: SystemChangeNotification-Tests-fbs.22 Use non logging Compiler protocol rather than providing a logged: false argument. ==================== Snapshot ==================== SystemOrganization addCategory: #'SystemChangeNotification-Tests'! TestCase subclass: #SystemChangeFileTest instanceVariableNames: 'tempChangesFile tempChangesName' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! ----- Method: SystemChangeFileTest>>change:verify: (in category 'testing') ----- change: changeBlock verify: verifyBlock self prepare: [] change: changeBlock verify: verifyBlock! ----- Method: SystemChangeFileTest>>createClass: (in category 'private') ----- createClass: name ^Object subclass: name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self genericClassCategory! ----- Method: SystemChangeFileTest>>directory (in category 'accessing') ----- directory "Where we want to place the temporary changes file" ^FileDirectory default! ----- Method: SystemChangeFileTest>>expectedFailures (in category 'testing') ----- expectedFailures ^#( #testCategoryModified #testClassReorganized #testProtocolModified )! ----- Method: SystemChangeFileTest>>genericChangesName (in category 'private') ----- genericChangesName ^self prefixChangesName, self randomString, '.changes'! ----- Method: SystemChangeFileTest>>genericClassCategory (in category 'private') ----- genericClassCategory ^(self prefixClassCategory, self randomString capitalized) asSymbol! ----- Method: SystemChangeFileTest>>genericClassName (in category 'private') ----- genericClassName ^(self prefixClassName, self randomString capitalized) asSymbol! ----- Method: SystemChangeFileTest>>genericInstVarName (in category 'private') ----- genericInstVarName ^(self prefixInstVarName, self randomString capitalized) asSymbol! ----- Method: SystemChangeFileTest>>genericProtocol (in category 'private') ----- genericProtocol ^(self prefixProtocol, self randomString) asSymbol! ----- Method: SystemChangeFileTest>>genericSelector (in category 'private') ----- genericSelector ^(self prefixSelector, self randomString capitalized) asSymbol! ----- Method: SystemChangeFileTest>>prefixChangesName (in category 'private') ----- prefixChangesName ^self prefixGeneral! ----- Method: SystemChangeFileTest>>prefixClassCategory (in category 'private') ----- prefixClassCategory ^self prefixGeneral, 'Category-'! ----- Method: SystemChangeFileTest>>prefixClassName (in category 'private') ----- prefixClassName ^self prefixGeneral, 'Class'! ----- Method: SystemChangeFileTest>>prefixGeneral (in category 'private') ----- prefixGeneral ^self class name select: [:each | each isUppercase]! ----- Method: SystemChangeFileTest>>prefixInstVarName (in category 'private') ----- prefixInstVarName ^self prefixGeneral asLowercase, 'InstVar'! ----- Method: SystemChangeFileTest>>prefixProtocol (in category 'private') ----- prefixProtocol ^self prefixGeneral asLowercase, ' protocol '! ----- Method: SystemChangeFileTest>>prefixSelector (in category 'private') ----- prefixSelector ^self prefixGeneral asLowercase, 'Selector'! ----- Method: SystemChangeFileTest>>prepare:change:verify: (in category 'testing') ----- prepare: prepareBlock change: changeBlock verify: verifyBlock "All tests follow this pattern. Beware that prepareBlock (and verifyBlock) will be evalutated twice." "Setup the testcourt" prepareBlock value. "Embrace the changeBlock so that any change to our testcourt will be recorded in our temporary changes file" self useTemporaryChangesFile. changeBlock value. "Check if the changes we made worked as expected. We need to do this before we switch back to the standard changes file" "We raise an Error if this fails, because then the testcase is broken" [verifyBlock value] on: TestFailure do: [self error: 'The verifyBlock needs to validate the changes made in the changeBlock']. self useStandardChangesFile. "Remove the testcourt completely" self removeTestcourt. "Setup the testcourt once again" prepareBlock value. "Replay the changes from the temporary changes file" self replayChanges. "See if we got the same changes as we did before using the changeBlock" verifyBlock value. ! ----- Method: SystemChangeFileTest>>randomString (in category 'private') ----- randomString ^Character alphabet shuffled! ----- Method: SystemChangeFileTest>>removeTestcourt (in category 'private') ----- removeTestcourt SystemOrganization categories do: [:each | (each beginsWith: self prefixClassCategory) ifTrue: [ SystemOrganization removeSystemCategory: each. ]. ]. ! ----- Method: SystemChangeFileTest>>replayChanges (in category 'private') ----- replayChanges | file | file := FileStream fileNamed: (self directory fullNameFor: self tempChangesName). Transcript show: file contents; cr. file fileIn. ! ----- Method: SystemChangeFileTest>>tearDown (in category 'running') ----- tearDown self useStandardChangesFile. tempChangesFile := tempChangesFile ifNotNil: [tempChangesFile close]. (self directory fileExists: self tempChangesName) ifTrue: [self directory deleteFileNamed: self tempChangesName]. self removeTestcourt. ! ----- Method: SystemChangeFileTest>>tempChangesName (in category 'accessing') ----- tempChangesName ^tempChangesName ifNil: [tempChangesName := self genericChangesName]! ----- Method: SystemChangeFileTest>>testCategoryAdded (in category 'testing') ----- testCategoryAdded | aClassCategory | aClassCategory := self genericClassCategory. self change: [ SystemOrganization addCategory: aClassCategory. ] verify: [ self assert: (SystemOrganization categories includes: aClassCategory). ] ! ----- Method: SystemChangeFileTest>>testCategoryAddedBefore (in category 'testing') ----- testCategoryAddedBefore | aClassCategory | aClassCategory := self genericClassCategory. self change: [ SystemOrganization addCategory: aClassCategory before: nil. ] verify: [ self assert: (SystemOrganization categories includes: aClassCategory). ] ! ----- Method: SystemChangeFileTest>>testCategoryModified (in category 'as yet unclassified') ----- testCategoryModified self assert: false description: 'When does that happen?'! ----- Method: SystemChangeFileTest>>testCategoryRemoved (in category 'testing') ----- testCategoryRemoved | aClassCategory | aClassCategory := self genericClassCategory. self prepare: [ SystemOrganization addCategory: aClassCategory. ] change: [ SystemOrganization removeCategory: aClassCategory. ] verify: [ self deny: (SystemOrganization categories includes: aClassCategory). ] ! ----- Method: SystemChangeFileTest>>testCategoryRenamed (in category 'testing') ----- testCategoryRenamed | aNewClassCategory anOldClassCategory | anOldClassCategory := self genericClassCategory. aNewClassCategory := self genericClassCategory. self prepare: [ SystemOrganization addCategory: anOldClassCategory. ] change: [ SystemOrganization renameCategory: anOldClassCategory toBe: aNewClassCategory ] verify: [ self assert: (SystemOrganization categories includes: aNewClassCategory). self deny: (SystemOrganization categories includes: anOldClassCategory). ] ! ----- Method: SystemChangeFileTest>>testClassAdded (in category 'testing') ----- testClassAdded | aClassName | aClassName := self genericClassName. self change: [ self createClass: aClassName. ] verify: [ self assert: (Smalltalk globals includesKey: aClassName). ] ! ----- Method: SystemChangeFileTest>>testClassCommented (in category 'testing') ----- testClassCommented | aClass aClassName aComment | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aComment := self randomString. aClass classComment: aComment. ] verify: [ self assert: aClass organization classComment string = aComment. ].! ----- Method: SystemChangeFileTest>>testClassModified (in category 'testing') ----- testClassModified | aClass aClassName aInstVarName | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aInstVarName := self genericInstVarName. aClass addInstVarName: aInstVarName. ] verify: [ self assert: (aClass instVarNames includes: aInstVarName). ].! ----- Method: SystemChangeFileTest>>testClassRecategorized (in category 'testing') ----- testClassRecategorized | aClassName aNewClassCategory | aClassName := self genericClassName. aNewClassCategory := self genericClassCategory. self prepare: [ self createClass: aClassName. SystemOrganization addCategory: aNewClassCategory. ] change: [ SystemOrganization classify: aClassName under: aNewClassCategory. ] verify: [ self assert: (SystemOrganization categoryOfElement: aClassName) = aNewClassCategory. ] ! ----- Method: SystemChangeFileTest>>testClassRemoved (in category 'testing') ----- testClassRemoved | aClass aClassName | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aClass removeFromSystem. ] verify: [ self deny: (Smalltalk globals includesKey: aClassName). ]. ! ----- Method: SystemChangeFileTest>>testClassRenamed (in category 'testing') ----- testClassRenamed | aClass aNewClassName anOldClassName | anOldClassName := self genericClassName. aNewClassName := self genericClassName. self prepare: [ aClass := self createClass: anOldClassName. ] change: [ aClass rename: aNewClassName. ] verify: [ self assert: (Smalltalk globals includesKey: aNewClassName). self deny: (Smalltalk globals includesKey: anOldClassName). ].! ----- Method: SystemChangeFileTest>>testClassReorganized (in category 'as yet unclassified') ----- testClassReorganized self assert: false description: 'When does that happen?'! ----- Method: SystemChangeFileTest>>testExpressionDoIt (in category 'testing') ----- testExpressionDoIt | aClassName | aClassName := self genericClassName.. self prepare: [ self createClass: aClassName. ] change: [ Compiler evaluate: '(Smalltalk at: ', aClassName storeString, ') removeFromSystem'. ] verify: [ self deny: (Smalltalk globals includesKey: aClassName). ].! ----- Method: SystemChangeFileTest>>testMethodAdded (in category 'testing') ----- testMethodAdded | aClassName aClass aSelector | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aSelector := self genericSelector. aClass compile: aSelector. ] verify: [ self assert: (aClass methodDict includesKey: aSelector). ] ! ----- Method: SystemChangeFileTest>>testMethodModified (in category 'testing') ----- testMethodModified | aClassName aClass aSelector aMethodSource | aClassName := self genericClassName. aSelector := self genericSelector. self prepare: [ aClass := self createClass: aClassName. aClass compile: aSelector, ' ', self randomString storeString. ] change: [ aMethodSource := aSelector, ' ', self randomString storeString. aClass compile: aMethodSource. ] verify: [ self assert: (aClass sourceCodeAt: aSelector) string = aMethodSource. ] ! ----- Method: SystemChangeFileTest>>testMethodRecategorized (in category 'testing') ----- testMethodRecategorized | aClassName aClass aNewProtocol aSelector anOldProtocol | aClassName := self genericClassName. aSelector := self genericSelector. anOldProtocol := self genericProtocol. self prepare: [ aClass := self createClass: aClassName. aClass compile: aSelector classified: anOldProtocol. ] change: [ aNewProtocol := self genericProtocol. aClass organization classify: aSelector under: aNewProtocol. ] verify: [ self assert: (aClass organization categoryOfElement: aSelector) = aNewProtocol ] ! ----- Method: SystemChangeFileTest>>testMethodRemoved (in category 'testing') ----- testMethodRemoved | aClassName aClass aSelector | aClassName := self genericClassName. aSelector := self genericSelector. self prepare: [ aClass := self createClass: aClassName. aClass compile: aSelector. ] change: [ aClass removeSelector: aSelector. ] verify: [ self deny: (aClass methodDict includesKey: aSelector). ] ! ----- Method: SystemChangeFileTest>>testProtocolAdded (in category 'testing') ----- testProtocolAdded | aClassName aClass aProtocol | aClassName := self genericClassName. aProtocol := self genericProtocol. self prepare: [ aClass := self createClass: aClassName. ] change: [ aClass organization addCategory: aProtocol. ] verify: [ self assert: (aClass organization categories includes: aProtocol) ] ! ----- Method: SystemChangeFileTest>>testProtocolDefault (in category 'testing') ----- testProtocolDefault | aClassName aClass aSelector | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aSelector := self genericSelector. aClass compile: aSelector. ] verify: [ self assert: (aClass organization categoryOfElement: aSelector) = aClass organization class default. ] ! ----- Method: SystemChangeFileTest>>testProtocolModified (in category 'as yet unclassified') ----- testProtocolModified self assert: false description: 'When does that happen?'! ----- Method: SystemChangeFileTest>>testProtocolRemoved (in category 'testing') ----- testProtocolRemoved | aClassName aClass aProtocol | aClassName := self genericClassName. aProtocol := self genericProtocol. self prepare: [ aClass := self createClass: aClassName. aClass organization addCategory: aProtocol. ] change: [ aClass organization removeCategory: aProtocol. ] verify: [ self deny: (aClass organization categories includes: aProtocol) ] ! ----- Method: SystemChangeFileTest>>testProtocolRenamed (in category 'testing') ----- testProtocolRenamed | aClassName aClass anOldProtocol aNewProtocol | aClassName := self genericClassName. anOldProtocol := self genericProtocol. self prepare: [ aClass := self createClass: aClassName. aClass organization addCategory: anOldProtocol. ] change: [ aNewProtocol := self genericProtocol. aClass organization renameCategory: anOldProtocol toBe: aNewProtocol. ] verify: [ self deny: (aClass organization categories includes: anOldProtocol). self assert: (aClass organization categories includes: aNewProtocol). ] ! ----- Method: SystemChangeFileTest>>useStandardChangesFile (in category 'private') ----- useStandardChangesFile Smalltalk closeSourceFiles; openSourceFiles! ----- Method: SystemChangeFileTest>>useTemporaryChangesFile (in category 'private') ----- useTemporaryChangesFile Smalltalk closeSourceFiles. tempChangesFile := self directory forceNewFileNamed: self tempChangesName. SourceFiles at: 2 put: tempChangesFile! TestCase subclass: #SystemChangeTestRoot instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! !SystemChangeTestRoot commentStamp: 'rw 4/5/2006 17:28' prior: 0! The Root test class for the System Change Notification tests.! SystemChangeTestRoot subclass: #ChangeHooksTest instanceVariableNames: 'previousChangeSet testsChangeSet capturedEvents generatedTestClass generatedTestClassX createdMethodName createdMethod doItExpression' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! !ChangeHooksTest commentStamp: 'bp 12/4/2009 10:37' prior: 0! This class implements unit tests to verify that when the system changes, notification messages are sent around correctly. Therefore the test messages make a system change, after registering to receive an event after the change occured. In this event (sent immediately after the change), the actual assertions take place. Note that the system changes are *really* made to the system, but in a change set that is created in the setUp method, while the previous one is restored in the tearDown method.! ----- Method: ChangeHooksTest>>addSingleEvent: (in category 'Private') ----- addSingleEvent: anEvent capturedEvents isEmpty ifFalse: [self assert: false]. capturedEvents add: anEvent! ----- Method: ChangeHooksTest>>checkEvent:kind:item:itemKind: (in category 'Private') ----- checkEvent: anEvent kind: changeKind item: item itemKind: itemKind self assert: (anEvent perform: ('is' , changeKind) asSymbol). self assert: anEvent item = item. self assert: anEvent itemKind = itemKind! ----- Method: ChangeHooksTest>>checkForOnlySingleEvent (in category 'Private') ----- checkForOnlySingleEvent self assert: capturedEvents size = 1! ----- Method: ChangeHooksTest>>classCommentedEvent: (in category 'Events-Classes') ----- classCommentedEvent: event self addSingleEvent: event. self assert: generatedTestClass comment = self commentStringForTesting. self checkEvent: event kind: #Commented item: generatedTestClass itemKind: AbstractEvent classKind! ----- Method: ChangeHooksTest>>classCreationEvent: (in category 'Events-Classes') ----- classCreationEvent: event | classCreated | self addSingleEvent: event. classCreated := Smalltalk classNamed: self newlyCreatedClassName. self assert: classCreated notNil. self assert: ((Smalltalk organization listAtCategoryNamed: #'System-Change Notification') includes: self newlyCreatedClassName). self checkEvent: event kind: #Added item: classCreated itemKind: AbstractEvent classKind! ----- Method: ChangeHooksTest>>classRecategorizedEvent: (in category 'Events-Classes') ----- classRecategorizedEvent: event self addSingleEvent: event. self checkEvent: event kind: #Recategorized item: generatedTestClass itemKind: AbstractEvent classKind. self assert: event oldCategory = #'System-Change Notification'! ----- Method: ChangeHooksTest>>classRedefinitionEvent: (in category 'Events-Classes') ----- classRedefinitionEvent: event self addSingleEvent: event. self checkEvent: event kind: #Modified item: generatedTestClass itemKind: AbstractEvent classKind.! ----- Method: ChangeHooksTest>>classRemovalEvent: (in category 'Events-Classes') ----- classRemovalEvent: event "This event used to be sent efter the class was removed. This was changed, and therefore this test is useless currently." self addSingleEvent: event. self assert: (Smalltalk classNamed: self generatedTestClassName) isNil. self checkEvent: event kind: #Removed item: self generatedTestClassName itemKind: AbstractEvent classKind! ----- Method: ChangeHooksTest>>classRenameEvent: (in category 'Events-Classes') ----- classRenameEvent: event | renamedClass | self addSingleEvent: event. renamedClass := Smalltalk classNamed: self renamedTestClassName. self assert: renamedClass notNil. self assert: (Smalltalk classNamed: self generatedTestClassName) isNil. self checkEvent: event kind: #Renamed item: renamedClass itemKind: AbstractEvent classKind. self assert: event oldName = self generatedTestClassName! ----- Method: ChangeHooksTest>>classSuperChangedEvent: (in category 'Events-Classes') ----- classSuperChangedEvent: event self addSingleEvent: event. self checkEvent: event kind: #Modified item: generatedTestClass itemKind: AbstractEvent classKind. self assert: generatedTestClass superclass = Model! ----- Method: ChangeHooksTest>>commentStringForTesting (in category 'Private') ----- commentStringForTesting ^'Added this comment as part of the unit test in SystemChangeTest>>testClassCommentedBasicEvents. You should never see this, unless you are debugging the system somewhere in between the tests.'! ----- Method: ChangeHooksTest>>generateTestClass (in category 'Private-Generation') ----- generateTestClass generatedTestClass := Object subclass: self generatedTestClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'.! ----- Method: ChangeHooksTest>>generateTestClassX (in category 'Private-Generation') ----- generateTestClassX generatedTestClassX := Object subclass: self generatedTestClassNameX instanceVariableNames: 'x' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'.! ----- Method: ChangeHooksTest>>generatedTestClassName (in category 'Private-Generation') ----- generatedTestClassName ^#'AutoGeneratedClassForTestingSystemChanges'! ----- Method: ChangeHooksTest>>generatedTestClassNameX (in category 'Private-Generation') ----- generatedTestClassNameX ^#'AutoGeneratedClassXForTestingSystemChanges'! ----- Method: ChangeHooksTest>>instanceVariableCreationEvent: (in category 'Events-Instance Variables') ----- instanceVariableCreationEvent: event self addSingleEvent: event. self assert: event isModified. self assert: event item = generatedTestClass. self assert: event itemKind = AbstractEvent classKind. self assert: event areInstVarsModified. self deny: event isSuperclassModified. self deny: event areClassVarsModified. self deny: event areSharedPoolsModified. ! ----- Method: ChangeHooksTest>>instanceVariableRemovedEvent: (in category 'Events-Instance Variables') ----- instanceVariableRemovedEvent: event self addSingleEvent: event. self assert: event isModified. self assert: event item = generatedTestClassX. self assert: event itemKind = AbstractEvent classKind. self assert: event areInstVarsModified. self deny: event isSuperclassModified. self deny: event areClassVarsModified. self deny: event areSharedPoolsModified. ! ----- Method: ChangeHooksTest>>methodCreationEvent1: (in category 'Events-Methods') ----- methodCreationEvent1: event | methodCreated | self addSingleEvent: event. methodCreated := generatedTestClass >> createdMethodName. self checkEvent: event kind: #Added item: methodCreated itemKind: AbstractEvent methodKind! ----- Method: ChangeHooksTest>>methodCreationEvent2: (in category 'Events-Methods') ----- methodCreationEvent2: event | methodCreated | self addSingleEvent: event. methodCreated := generatedTestClass >> createdMethodName. self checkEvent: event kind: #Added item: methodCreated itemKind: AbstractEvent methodKind! ----- Method: ChangeHooksTest>>methodDoItEvent1: (in category 'Events-Expression') ----- methodDoItEvent1: event self addSingleEvent: event. self checkEvent: event kind: #DoIt item: doItExpression itemKind: AbstractEvent expressionKind. self assert: event context isNil.! ----- Method: ChangeHooksTest>>methodRecategorizationEvent: (in category 'Events-Methods') ----- methodRecategorizationEvent: event | methodCreated | self addSingleEvent: event. methodCreated := generatedTestClass >> createdMethodName. self assert: ((generatedTestClass organization categoryOfElement: createdMethodName) = #newCategory). self assert: event oldCategory = #testing. self checkEvent: event kind: #Recategorized item: methodCreated itemKind: AbstractEvent methodKind.! ----- Method: ChangeHooksTest>>methodRemovedEvent1: (in category 'Events-Methods') ----- methodRemovedEvent1: event self addSingleEvent: event. self should: [generatedTestClass >> createdMethodName] raise: Error. self checkEvent: event kind: #Removed item: createdMethod itemKind: AbstractEvent methodKind. event itemClass = generatedTestClass. event itemMethod = createdMethodName. self assert: ((generatedTestClass organization categoryOfElement: createdMethodName) isNil).! ----- Method: ChangeHooksTest>>methodRemovedEvent2: (in category 'Events-Methods') ----- methodRemovedEvent2: event self methodRemovedEvent1: event! ----- Method: ChangeHooksTest>>newlyCreatedClassName (in category 'Private-Generation') ----- newlyCreatedClassName ^#'AutoGeneratedClassWhileTestingSystemChanges'! ----- Method: ChangeHooksTest>>rememberEvent: (in category 'Events-General') ----- rememberEvent: event capturedEvents add: event! ----- Method: ChangeHooksTest>>removeGeneratedTestClasses (in category 'Private') ----- removeGeneratedTestClasses "Remove all classes that were possibly generated during testing." | possiblyToRemove | possiblyToRemove := OrderedCollection with: self generatedTestClassName with: self generatedTestClassNameX with: self renamedTestClassName with: self newlyCreatedClassName. possiblyToRemove do: [:name | (Smalltalk hasClassNamed: name) ifTrue: [(Smalltalk at: name) removeFromSystemUnlogged]]. generatedTestClass := nil. generatedTestClassX := nil! ----- Method: ChangeHooksTest>>renamedTestClassName (in category 'Private-Generation') ----- renamedTestClassName ^#'AutoRenamedClassForTestingSystemChanges'! ----- Method: ChangeHooksTest>>setUp (in category 'Running') ----- setUp previousChangeSet := ChangeSet current. testsChangeSet := ChangeSet new. ChangeSet newChanges: testsChangeSet. capturedEvents := OrderedCollection new. self generateTestClass. self generateTestClassX. super setUp! ----- Method: ChangeHooksTest>>shouldNotBeCalledEvent: (in category 'Events-General') ----- shouldNotBeCalledEvent: anEvent "This event should not be called, so fail the test." self assert: false! ----- Method: ChangeHooksTest>>tearDown (in category 'Running') ----- tearDown self removeGeneratedTestClasses. ChangeSet newChanges: previousChangeSet. ChangesOrganizer removeChangeSet: testsChangeSet. previousChangeSet := nil. testsChangeSet := nil. capturedEvents := nil. createdMethod := nil. super tearDown! ----- Method: ChangeHooksTest>>testClassCommentedEvent (in category 'Testing-Classes') ----- testClassCommentedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classCommentedEvent:. generatedTestClass comment: self commentStringForTesting. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassCreationEvent (in category 'Testing-Classes') ----- testClassCreationEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classCreationEvent:. Object subclass: self newlyCreatedClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassRecategorizedEvent1 (in category 'Testing-Classes') ----- testClassRecategorizedEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRecategorizedEvent:. Object subclass: generatedTestClass name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassRecategorizedEvent2 (in category 'Testing-Classes') ----- testClassRecategorizedEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRecategorizedEvent:. generatedTestClass category: 'Collections-Abstract'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassRedefinition (in category 'Testing-Classes') ----- testClassRedefinition self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRedefinitionEvent:. self generateTestClass! ----- Method: ChangeHooksTest>>testClassRemovalEvent (in category 'Testing-Classes') ----- testClassRemovalEvent "This event used to be sent efter the class was removed. This was changed, and therefore this test is useless currently." "Keep it, since I really want to check with the responsible for the ChangeSet, and it is very likely this will be reintroduced afterwards!!" " | createdClass | createdClass := self compileUniqueClass. self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRemovalEvent:. createdClass removeFromSystem. self checkForOnlySingleEvent "! ----- Method: ChangeHooksTest>>testClassRenamedEvent (in category 'Testing-Classes') ----- testClassRenamedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRenameEvent:. generatedTestClass rename: self renamedTestClassName. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassSuperChangedEvent (in category 'Testing-Classes') ----- testClassSuperChangedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classSuperChangedEvent:. Model subclass: generatedTestClass name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testDoItEvent1 (in category 'Testing-Expression') ----- testDoItEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodDoItEvent1:. doItExpression := '1 + 2'. Compiler evaluate: doItExpression logged: true. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testDoItEvent2 (in category 'Testing-Expression') ----- testDoItEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #shouldNotBeCalledEvent:. doItExpression := '1 + 2'. Compiler evaluate: doItExpression! ----- Method: ChangeHooksTest>>testInstanceVariableCreationEvent1 (in category 'Testing-Instance Variables') ----- testInstanceVariableCreationEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #instanceVariableCreationEvent:. Object subclass: self generatedTestClassName instanceVariableNames: 'x' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testInstanceVariableCreationEvent2 (in category 'Testing-Instance Variables') ----- testInstanceVariableCreationEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #instanceVariableCreationEvent:. generatedTestClass addInstVarName: 'x'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testInstanceVariableRemovedEvent1 (in category 'Testing-Instance Variables') ----- testInstanceVariableRemovedEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #instanceVariableRemovedEvent:. Object subclass: generatedTestClassX name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testInstanceVariableRemovedEvent2 (in category 'Testing-Instance Variables') ----- testInstanceVariableRemovedEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #instanceVariableRemovedEvent:. generatedTestClassX removeInstVarName: 'x'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testInstanceVariableRenamedSilently (in category 'Testing-Instance Variables') ----- testInstanceVariableRenamedSilently self systemChangeNotifier notify: self ofAllSystemChangesUsing: #shouldNotBeCalledEvent:. generatedTestClassX renameSilentlyInstVar: 'x' to: 'y'! ----- Method: ChangeHooksTest>>testMethodCreationEvent1 (in category 'Testing-Methods') ----- testMethodCreationEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodCreationEvent1:. createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testMethodCreationEvent2 (in category 'Testing-Methods') ----- testMethodCreationEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodCreationEvent2:. createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1' classified: #testing. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testMethodRecategorizationEvent (in category 'Testing-Methods') ----- testMethodRecategorizationEvent createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1' classified: #testing. self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodRecategorizationEvent:. generatedTestClass organization classify: createdMethodName under: #newCategory suppressIfDefault: false. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testMethodRemovedEvent1 (in category 'Testing-Methods') ----- testMethodRemovedEvent1 createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1'. createdMethod := generatedTestClass >> createdMethodName. self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodRemovedEvent1:. generatedTestClass removeSelector: createdMethodName. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testMethodRemovedEvent2 (in category 'Testing-Methods') ----- testMethodRemovedEvent2 createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1'. createdMethod := generatedTestClass >> createdMethodName. self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodRemovedEvent2:. Smalltalk removeSelector: (Array with: generatedTestClass name with: createdMethodName). self checkForOnlySingleEvent! SystemChangeTestRoot subclass: #SystemChangeErrorHandling instanceVariableNames: 'capturedEvents' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! !SystemChangeErrorHandling commentStamp: 'bp 12/4/2009 10:37' prior: 0! This class tests the error handing of the notification mechanism to ensure that one client that receives a system change cannot lock up the complete system.! ----- Method: SystemChangeErrorHandling>>handleEventWithError: (in category 'Event Notifications') ----- handleEventWithError: event self error: 'Example of event handling code that throws an error.'! ----- Method: SystemChangeErrorHandling>>handleEventWithHalt: (in category 'Event Notifications') ----- handleEventWithHalt: event self halt: 'Example of event handling code that contains a halt.'! ----- Method: SystemChangeErrorHandling>>setUp (in category 'Running') ----- setUp super setUp. capturedEvents := OrderedCollection new! ----- Method: SystemChangeErrorHandling>>storeEvent1: (in category 'Event Notifications') ----- storeEvent1: anEvent capturedEvents add: anEvent! ----- Method: SystemChangeErrorHandling>>storeEvent2: (in category 'Event Notifications') ----- storeEvent2: anEvent capturedEvents add: anEvent! ----- Method: SystemChangeErrorHandling>>storeEvent3: (in category 'Event Notifications') ----- storeEvent3: anEvent capturedEvents add: anEvent! ----- Method: SystemChangeErrorHandling>>tearDown (in category 'Running') ----- tearDown capturedEvents := nil. super tearDown! ----- Method: SystemChangeErrorHandling>>testErrorOperation (in category 'Testing') ----- testErrorOperation | notifier wasCaptured | notifier := self systemChangeNotifier. wasCaptured := false. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent1:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent2:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #handleEventWithError:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent3:. [notifier classAdded: self class inCategory: #FooCat] on: Error do: [:exc | wasCaptured := true. self assert: (capturedEvents size = 3)]. self assert: wasCaptured.! ----- Method: SystemChangeErrorHandling>>testHaltOperation (in category 'Testing') ----- testHaltOperation | notifier wasCaptured | notifier := self systemChangeNotifier. wasCaptured := false. notifier notify: self ofAllSystemChangesUsing: #storeEvent1:. notifier notify: self ofAllSystemChangesUsing: #storeEvent2:. notifier notify: self ofAllSystemChangesUsing: #handleEventWithHalt:. notifier notify: self ofAllSystemChangesUsing: #storeEvent3:. [notifier classAdded: self class inCategory: #FooCat] on: Halt do: [:exc | wasCaptured := true. self assert: (capturedEvents size = 3)]. self assert: wasCaptured.! ----- Method: SystemChangeErrorHandling>>testUnhandledEventOperation (in category 'Testing') ----- testUnhandledEventOperation | notifier wasCaptured | notifier := self systemChangeNotifier. wasCaptured := false. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent1:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent2:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #zork:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent3:. [notifier classAdded: self class inCategory: #FooCat] on: MessageNotUnderstood do: [:exc | wasCaptured := true. self assert: (capturedEvents size = 3)]. self assert: wasCaptured.! SystemChangeTestRoot subclass: #SystemChangeErrorHandlingTest instanceVariableNames: 'capturedEvents' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! SystemChangeTestRoot subclass: #SystemChangeNotifierTest instanceVariableNames: 'capturedEvent notifier' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! !SystemChangeNotifierTest commentStamp: 'rw 4/3/2006 17:19' prior: 0! A SystemChangeNotifierTest is a test class that tests whether the triggering of changes indeed results in the intended changes to be sent to registered object. The basic mechanism for each test is fairly simple: - register the receiver as the one to get the change notifier. - manually trigger a change (so the system is not polluted just to see whether we get the needed event). - the method #event: is invoked and remembers the change event. - the change event is checked to see whether it was the intended one. Instance Variables capturedEvent: Remembers the captured event! ----- Method: SystemChangeNotifierTest>>capturedEvent: (in category 'Private') ----- capturedEvent: eventOrNil "Remember the event being sent." capturedEvent := eventOrNil! ----- Method: SystemChangeNotifierTest>>checkEventForClass:category:change: (in category 'Private') ----- checkEventForClass: aClass category: cat change: changeKind self assert: (capturedEvent perform: ('is' , changeKind) asSymbol). self assert: capturedEvent item = aClass. self assert: capturedEvent itemKind = AbstractEvent classKind. self assert: capturedEvent itemClass = aClass. self assert: capturedEvent itemCategory = cat! ----- Method: SystemChangeNotifierTest>>checkEventForMethod:protocol:change: (in category 'Private') ----- checkEventForMethod: aMethod protocol: prot change: changeKind self assert: (capturedEvent perform: ('is' , changeKind) asSymbol). self assert: capturedEvent item = aMethod. self assert: capturedEvent itemKind = AbstractEvent methodKind. self assert: capturedEvent itemClass = self class. self assert: capturedEvent itemMethod = aMethod. self assert: capturedEvent itemProtocol = prot! ----- Method: SystemChangeNotifierTest>>checkEventForMethod:protocol:change:oldMethod: (in category 'Private') ----- checkEventForMethod: aMethod protocol: prot change: changeKind oldMethod: oldMethod self checkEventForMethod: aMethod protocol: prot change: changeKind. self assert: capturedEvent oldItem == oldMethod ! ----- Method: SystemChangeNotifierTest>>event: (in category 'Event Notifications') ----- event: event "The notification message being sent to me when an event is captured. Remember it." " capturedEvent isNil ifTrue: [ self capturedEvent: event] ifFalse: [self assert: false]" self capturedEvent: event! ----- Method: SystemChangeNotifierTest>>setUp (in category 'Running') ----- setUp super setUp. notifier := SystemChangeNotifier createInstance.! ----- Method: SystemChangeNotifierTest>>systemChangeNotifier (in category 'Private') ----- systemChangeNotifier "The notifier to use. Do not use the one in the system so that the fake events triggered in the tests perturb clients of the system's change notifier (e.g. the changes file then shows fake entries)." ^notifier! ----- Method: SystemChangeNotifierTest>>tearDown (in category 'Running') ----- tearDown super tearDown. self capturedEvent: nil. notifier releaseAll. notifier := nil! ----- Method: SystemChangeNotifierTest>>testClassAddedEvent (in category 'Testing-system triggers') ----- testClassAddedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier classAdded: self class inCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Added! ----- Method: SystemChangeNotifierTest>>testClassAddedEvent2 (in category 'Testing-system triggers') ----- testClassAddedEvent2 self systemChangeNotifier notify: self ofSystemChangesOfItem: #class change: #Added using: #event:. self systemChangeNotifier classAdded: self class inCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Added! ----- Method: SystemChangeNotifierTest>>testClassCommentedEvent (in category 'Testing-system triggers') ----- testClassCommentedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier classCommented: self class inCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Commented! ----- Method: SystemChangeNotifierTest>>testClassRecategorizedEvent (in category 'Testing-system triggers') ----- testClassRecategorizedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier class: self class recategorizedFrom: #FooCat to: #FooBar. self checkEventForClass: self class category: #FooBar change: #Recategorized. self assert: capturedEvent oldCategory = #FooCat! ----- Method: SystemChangeNotifierTest>>testClassRemovedEvent (in category 'Testing-system triggers') ----- testClassRemovedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier classRemoved: self class fromCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Removed! ----- Method: SystemChangeNotifierTest>>testClassRenamedEvent (in category 'Testing-system triggers') ----- testClassRenamedEvent "self run: #testClassRenamedEvent" self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier classRenamed: self class from: #OldFooClass to: #NewFooClass inCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Renamed. " self assert: capturedEvent oldName = #OldFooClass. self assert: capturedEvent newName = #NewFooClass"! ----- Method: SystemChangeNotifierTest>>testDoItEvent (in category 'Testing-system triggers') ----- testDoItEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier evaluated: '1 + 2' context: self. self assert: capturedEvent isDoIt. self assert: capturedEvent item = '1 + 2'. self assert: capturedEvent itemKind = AbstractEvent expressionKind. self assert: capturedEvent itemClass = nil. self assert: capturedEvent itemMethod = nil. self assert: capturedEvent itemProtocol = nil. self assert: capturedEvent itemExpression = '1 + 2'. self assert: capturedEvent context = self.! ----- Method: SystemChangeNotifierTest>>testMethodAddedEvent1 (in category 'Testing-system triggers') ----- testMethodAddedEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier methodAdded: self class >> #testMethodAddedEvent1 selector: #testMethodAddedEvent1 inProtocol: #FooCat class: self class. self checkEventForMethod: self class >> #testMethodAddedEvent1 protocol: #FooCat change: #Added! ----- Method: SystemChangeNotifierTest>>testMethodAddedEvent2 (in category 'Testing-system triggers') ----- testMethodAddedEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier methodAdded: self class >> #testMethodAddedEvent1 selector: #testMethodAddedEvent1 inClass: self class. self checkEventForMethod: self class >> #testMethodAddedEvent1 protocol: nil change: #Added! ----- Method: SystemChangeNotifierTest>>testMethodAddedEvent3 (in category 'Testing-system triggers') ----- testMethodAddedEvent3 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier methodChangedFrom: self class >> #testMethodAddedEvent1 to: self class >> #testMethodAddedEvent2 selector: #testMethodAddedEvent2 inClass: self class. self checkEventForMethod: self class >> #testMethodAddedEvent2 protocol: nil change: #Modified oldMethod: self class >> #testMethodAddedEvent1.! ----- Method: SystemChangeNotifierTest>>testMethodRemovedEvent (in category 'Testing-system triggers') ----- testMethodRemovedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier methodRemoved: self class>> #testMethodRemovedEvent selector: #testMethodRemovedEvent inProtocol: #FooCat class: self class. self checkEventForMethod: self class>> #testMethodRemovedEvent protocol: #FooCat change: #Removed.! ----- Method: SystemChangeTestRoot>>systemChangeNotifier (in category 'Private') ----- systemChangeNotifier "The notifier to use. Use the one for the system." ^SystemChangeNotifier uniqueInstance! ----- Method: SystemChangeTestRoot>>tearDown (in category 'Running') ----- tearDown self unhook. super tearDown! ----- Method: SystemChangeTestRoot>>unhook (in category 'Running') ----- unhook self systemChangeNotifier noMoreNotificationsFor: self! From commits at source.squeak.org Fri Jun 5 20:13:40 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:13:50 2015 Subject: [squeak-dev] Squeak 4.6: MorphicExtrasTests-fbs.3.mcz Message-ID: Chris Muller uploaded a new version of MorphicExtrasTests to project Squeak 4.6: http://source.squeak.org/squeak46/MorphicExtrasTests-fbs.3.mcz ==================== Summary ==================== Name: MorphicExtrasTests-fbs.3 Author: fbs Time: 30 November 2013, 11:03:19.679 pm UUID: 1c039763-bc92-834c-943e-d96d8820cbd7 Ancestors: MorphicExtrasTests-fbs.2 Tests for MorphicExtras's selector mangling. ==================== Snapshot ==================== SystemOrganization addCategory: #'MorphicExtrasTests-Postscript Filters'! SystemOrganization addCategory: #'MorphicExtrasTests-Flaps'! TestCase subclass: #ByteEncoderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtrasTests-Postscript Filters'! ----- Method: ByteEncoderTest>>testIntegerByteEncoded (in category 'testing') ----- testIntegerByteEncoded self assert: (ByteEncoder stream writeNumber: 2 base: 2; yourself) contents = '10'. self assert: (ByteEncoder stream writeNumber: 21 base: 3; yourself) contents = '210'. self assert: (ByteEncoder stream writeNumber: 228 base: 4; yourself) contents = '3210'. self assert: (ByteEncoder stream writeNumber: 2930 base: 5; yourself) contents = '43210'. self assert: (ByteEncoder stream writeNumber: 44790 base: 6; yourself) contents = '543210'. self assert: (ByteEncoder stream writeNumber: 800667 base: 7; yourself) contents = '6543210'. self assert: (ByteEncoder stream writeNumber: 16434824 base: 8; yourself) contents = '76543210'. self assert: (ByteEncoder stream writeNumber: 381367044 base: 9; yourself) contents = '876543210'. self assert: (ByteEncoder stream writeNumber: 9876543210 base: 10; yourself) contents = '9876543210'. self assert: (ByteEncoder stream writeNumber: 282458553905 base: 11; yourself) contents = 'A9876543210'. self assert: (ByteEncoder stream writeNumber: 8842413667692 base: 12; yourself) contents = 'BA9876543210'. self assert: (ByteEncoder stream writeNumber: 300771807240918 base: 13; yourself) contents = 'CBA9876543210'. self assert: (ByteEncoder stream writeNumber: 11046255305880158 base: 14; yourself) contents = 'DCBA9876543210'. self assert: (ByteEncoder stream writeNumber: 435659737878916215 base: 15; yourself) contents = 'EDCBA9876543210'. self assert: (ByteEncoder stream writeNumber: 18364758544493064720 base: 16; yourself) contents = 'FEDCBA9876543210'. self assert: (ByteEncoder stream writeNumber: -2 base: 2; yourself) contents = '-10'. self assert: (ByteEncoder stream writeNumber: -21 base: 3; yourself) contents = '-210'. self assert: (ByteEncoder stream writeNumber: -228 base: 4; yourself) contents = '-3210'. self assert: (ByteEncoder stream writeNumber: -2930 base: 5; yourself) contents = '-43210'. self assert: (ByteEncoder stream writeNumber: -44790 base: 6; yourself) contents = '-543210'. self assert: (ByteEncoder stream writeNumber: -800667 base: 7; yourself) contents = '-6543210'. self assert: (ByteEncoder stream writeNumber: -16434824 base: 8; yourself) contents = '-76543210'. self assert: (ByteEncoder stream writeNumber: -381367044 base: 9; yourself) contents = '-876543210'. self assert: (ByteEncoder stream writeNumber: -9876543210 base: 10; yourself) contents = '-9876543210'. self assert: (ByteEncoder stream writeNumber: -282458553905 base: 11; yourself) contents = '-A9876543210'. self assert: (ByteEncoder stream writeNumber: -8842413667692 base: 12; yourself) contents = '-BA9876543210'. self assert: (ByteEncoder stream writeNumber: -300771807240918 base: 13; yourself) contents = '-CBA9876543210'. self assert: (ByteEncoder stream writeNumber: -11046255305880158 base: 14; yourself) contents = '-DCBA9876543210'. self assert: (ByteEncoder stream writeNumber: -435659737878916215 base: 15; yourself) contents = '-EDCBA9876543210'. self assert: (ByteEncoder stream writeNumber: -18364758544493064720 base: 16; yourself) contents = '-FEDCBA9876543210'.! TestCase subclass: #FlapTabTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtrasTests-Flaps'! !FlapTabTests commentStamp: 'wiz 6/11/2007 17:58' prior: 0! A FlapTabTests is here to test infinite recursion bug when extent: message is sent to some flap tabs see http://bugs.squeak.org/view.php?id=6486 for report. Instance Variables We inherit cases which can be filled with morphs that need to be deleted at the end of the test. ! ----- Method: FlapTabTests>>testFlapTabRecusion (in category 'tests') ----- testFlapTabRecusion | a b tab | "Create a float close to 466.700581395349" a := 1.1 at: 1 put: 1081944885; at: 2 put: 2497074009; yourself. b := 105. self deny: a + b - a = b. tab := Flaps newFlapTitled: 'Test' onEdge: #top. tab left: a. self should: [tab extent: b asPoint] notTakeMoreThanMilliseconds: 10 ! TestCase subclass: #MorphicExtrasSymbolExtensionsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtrasTests-Flaps'! ----- Method: MorphicExtrasSymbolExtensionsTest>>testAsSimpleSetterReturnsSetterSelector (in category 'as yet unclassified') ----- testAsSimpleSetterReturnsSetterSelector self assert: #foo: equals: #foo asSimpleSetter. "And it really is 'simple':" self assert: #foo:: equals: #foo: asSimpleSetter.! From commits at source.squeak.org Fri Jun 5 20:13:59 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:14:00 2015 Subject: [squeak-dev] Squeak 4.6: MonticelloForTraits-fbs.1.mcz Message-ID: Chris Muller uploaded a new version of MonticelloForTraits to project Squeak 4.6: http://source.squeak.org/squeak46/MonticelloForTraits-fbs.1.mcz ==================== Summary ==================== Name: MonticelloForTraits-fbs.1 Author: fbs Time: 9 August 2013, 8:46:48.716 am UUID: 160be615-5ab7-4148-a7cb-60dd629ab085 Ancestors: Initial commit. This package extends Monticello to support Traits. It exists so that one may freely unload Monticello, Traits, or both, in an image. ==================== Snapshot ==================== ----- Method: Trait>>asClassDefinition (in category '*MonticelloForTraits') ----- asClassDefinition ^Smalltalk at: #MCTraitDefinition ifPresent:[:aClass| aClass name: self name traitComposition: self traitCompositionString category: self category comment: self organization classComment asString commentStamp: self organization commentStamp].! ----- Method: Trait>>classDefinitions (in category '*MonticelloForTraits') ----- classDefinitions | definitions | definitions := OrderedCollection with: self asClassDefinition. (self hasClassTrait and: [self classTrait hasTraitComposition and: [self classTrait traitComposition isEmpty not]]) ifTrue: [definitions add: self classTrait asMCDefinition]. ^definitions asArray! From commits at source.squeak.org Fri Jun 5 20:14:34 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:14:36 2015 Subject: [squeak-dev] Squeak 4.6: ToolBuilder-SUnit-fbs.19.mcz Message-ID: Chris Muller uploaded a new version of ToolBuilder-SUnit to project Squeak 4.6: http://source.squeak.org/squeak46/ToolBuilder-SUnit-fbs.19.mcz ==================== Summary ==================== Name: ToolBuilder-SUnit-fbs.19 Author: fbs Time: 9 January 2014, 2:54:40.438 pm UUID: 3e30756c-2af8-0741-836f-0d42a9d5af32 Ancestors: ToolBuilder-SUnit-fbs.18 Move ToolBuilder's SUnit "extensions" - the stubs we use to test ToolBuilder-built components - back to ToolBuilder-SUnit. Otherwise we break the modularity between SUnit('s GUI) and ToolBuilder. ==================== Snapshot ==================== SystemOrganization addCategory: #'ToolBuilder-SUnit'! Object subclass: #WidgetStub instanceVariableNames: 'spec state' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! WidgetStub subclass: #ButtonStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: ButtonStub>>click (in category 'simulating') ----- click | action | action := spec action. action isSymbol ifTrue: [self model perform: action] ifFalse: [action value]! ----- Method: ButtonStub>>color (in category 'simulating') ----- color ^ state at: #color! ----- Method: ButtonStub>>isEnabled (in category 'simulating') ----- isEnabled ^ state at: #enabled! ----- Method: ButtonStub>>isPressed (in category 'simulating') ----- isPressed ^ state at: #state! ----- Method: ButtonStub>>label (in category 'simulating') ----- label ^ state at: #label! ----- Method: ButtonStub>>stateVariables (in category 'events') ----- stateVariables ^ #(label color state enabled)! WidgetStub subclass: #CompositeStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: CompositeStub>>children (in category 'accessing') ----- children ^ state at: #children ifAbsent: [#()]! ----- Method: CompositeStub>>children: (in category 'accessing') ----- children: anObject state at: #children put: anObject! ----- Method: CompositeStub>>stateVariables (in category 'accessing') ----- stateVariables ^ #(children)! ----- Method: CompositeStub>>widgetNamed: (in category 'accessing') ----- widgetNamed: aString self name = aString ifTrue: [^ self] ifFalse: [self children do: [:ea | (ea widgetNamed: aString) ifNotNil: [:w | ^ w]]]. ^ nil! CompositeStub subclass: #PanelStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! CompositeStub subclass: #WindowStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: WindowStub>>close (in category 'simulating') ----- close spec model perform: spec closeAction! ----- Method: WindowStub>>stateVariables (in category 'events') ----- stateVariables ^ super stateVariables, #(label)! WidgetStub subclass: #ListStub instanceVariableNames: 'list index' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: ListStub>>click: (in category 'simulating') ----- click: aString self clickItemAt: (self list indexOf: aString)! ----- Method: ListStub>>clickItemAt: (in category 'simulating') ----- clickItemAt: anInteger | selector | selector := spec setIndex. selector ifNil: [self model perform: spec setSelected with: (self list at: anInteger)] ifNotNil: [self model perform: selector with: anInteger] ! ----- Method: ListStub>>list (in category 'simulating') ----- list ^ list ifNil: [Array new]! ----- Method: ListStub>>menu (in category 'simulating') ----- menu ^ MenuStub fromSpec: (self model perform: spec menu with: (PluggableMenuSpec withModel: self model))! ----- Method: ListStub>>refresh (in category 'events') ----- refresh self refreshList. self refreshIndex! ----- Method: ListStub>>refreshIndex (in category 'events') ----- refreshIndex | selector | selector := spec getIndex. index := selector ifNil: [self list indexOf: (self model perform: spec getSelected)] ifNotNil: [spec model perform: selector] ! ----- Method: ListStub>>refreshList (in category 'events') ----- refreshList list := self model perform: spec list! ----- Method: ListStub>>selectedIndex (in category 'simulating') ----- selectedIndex ^ index ifNil: [0]! ----- Method: ListStub>>selectedItem (in category 'simulating') ----- selectedItem | items idx | (items := self list) isEmpty ifTrue: [^ nil]. (idx := self selectedIndex) = 0 ifTrue: [^ nil]. ^ items at: idx ! ----- Method: ListStub>>update: (in category 'events') ----- update: aSelector aSelector = spec list ifTrue: [^ self refreshList]. aSelector = spec getSelected ifTrue: [^ self refreshIndex]. aSelector = spec getIndex ifTrue: [^ self refreshIndex]. ^ super update: aSelector! WidgetStub subclass: #MenuStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: MenuStub>>click: (in category 'as yet unclassified') ----- click: aString | item | item := self items detect: [:ea | ea label = aString] ifNone: [^ self]. item action isSymbol ifTrue: [self model perform: item action] ifFalse: [item action value]! ----- Method: MenuStub>>items (in category 'as yet unclassified') ----- items ^ spec items! ----- Method: MenuStub>>labels (in category 'as yet unclassified') ----- labels ^ self items keys! WidgetStub subclass: #TextStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: TextStub>>accept: (in category 'simulating') ----- accept: aString state at: #getText put: aString. ^ self model perform: spec setText with: aString asText! ----- Method: TextStub>>color (in category 'simulating') ----- color ^ state at: #color! ----- Method: TextStub>>stateVariables (in category 'events') ----- stateVariables ^ #(color selection getText)! ----- Method: TextStub>>text (in category 'simulating') ----- text ^ state at: #getText! WidgetStub subclass: #TreeNodeStub instanceVariableNames: 'item' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: TreeNodeStub class>>fromSpec:item: (in category 'instance creation') ----- fromSpec: aSpec item: anObject ^ self new setSpec: aSpec item: anObject! ----- Method: TreeNodeStub>>children (in category 'simulating') ----- children ^ (self model perform: spec getChildren with: item) collect: [:ea | TreeNodeStub fromSpec: spec item: ea]! ----- Method: TreeNodeStub>>item (in category 'simulating') ----- item ^ item! ----- Method: TreeNodeStub>>label (in category 'simulating') ----- label ^ self model perform: spec label with: item! ----- Method: TreeNodeStub>>matches: (in category 'private') ----- matches: aString ^ self label = aString! ----- Method: TreeNodeStub>>openPath: (in category 'events') ----- openPath: anArray | child | anArray isEmpty ifTrue: [self select] ifFalse: [child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select]. child openPath: anArray allButFirst] ! ----- Method: TreeNodeStub>>printOn: (in category 'printing') ----- printOn: aStream aStream print: self class; nextPut: $<; print: item; nextPut: $>! ----- Method: TreeNodeStub>>select (in category 'simulating') ----- select self model perform: spec setSelected with: item! ----- Method: TreeNodeStub>>selectPath: (in category 'private') ----- selectPath: anArray | child | anArray isEmpty ifTrue: [^ self select]. child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select]. child selectPath: anArray allButFirst.! ----- Method: TreeNodeStub>>setSpec:item: (in category 'initialize-release') ----- setSpec: aSpec item: anObject super setSpec: aSpec. item := anObject! WidgetStub subclass: #TreeStub instanceVariableNames: 'roots' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: TreeStub>>openPath: (in category 'private') ----- openPath: anArray | first | first := roots detect: [:ea | ea matches: anArray first] ifNone: [^ self]. first openPath: anArray allButFirst! ----- Method: TreeStub>>roots: (in category 'private') ----- roots: anArray roots := anArray collect: [:ea | TreeNodeStub fromSpec: spec item: ea]. ! ----- Method: TreeStub>>select: (in category 'simulating') ----- select: anArray self openPath: anArray! ----- Method: TreeStub>>setSpec: (in category 'initialize-release') ----- setSpec: aSpec super setSpec: aSpec. self update: spec roots! ----- Method: TreeStub>>update: (in category 'events') ----- update: anObject anObject == spec roots ifTrue: [^ self updateRoots]. anObject == spec getSelectedPath ifTrue: [^ self updateSelectedPath]. (anObject isKindOf: Array) ifTrue: [^ self openPath: anObject allButFirst]. super update: anObject ! ----- Method: TreeStub>>updateRoots (in category 'events') ----- updateRoots ^ self roots: (self model perform: spec roots) ! ----- Method: TreeStub>>updateSelectedPath (in category 'events') ----- updateSelectedPath | path first | path := self model perform: spec getSelectedPath. first := roots detect: [:ea | ea item = path first] ifNone: [^ self]. first selectPath: path allButFirst.! ----- Method: WidgetStub class>>fromSpec: (in category 'instance creation') ----- fromSpec: aSpec ^ self new setSpec: aSpec! ----- Method: WidgetStub>>model (in category 'simulating') ----- model ^ spec model! ----- Method: WidgetStub>>name (in category 'accessing') ----- name ^ spec name ifNil: [' ']! ----- Method: WidgetStub>>printOn: (in category 'printing') ----- printOn: aStream aStream print: self class; nextPut: $<; nextPutAll: self name; nextPut: $>! ----- Method: WidgetStub>>refresh (in category 'events') ----- refresh self stateVariables do: [:var | self refresh: var]! ----- Method: WidgetStub>>refresh: (in category 'events') ----- refresh: var | value | value := spec perform: var. self refresh: var with: value! ----- Method: WidgetStub>>refresh:with: (in category 'events') ----- refresh: var with: value state at: var put: (value isSymbol ifTrue: [spec model perform: value] ifFalse: [value])! ----- Method: WidgetStub>>setSpec: (in category 'initialize-release') ----- setSpec: aSpec state := IdentityDictionary new. spec := aSpec. spec model addDependent: self. self refresh.! ----- Method: WidgetStub>>spec (in category 'accessing') ----- spec ^ spec! ----- Method: WidgetStub>>stateVariables (in category 'events') ----- stateVariables ^ #()! ----- Method: WidgetStub>>update: (in category 'events') ----- update: aSymbol self stateVariables do: [:var | (spec perform: var) == aSymbol ifTrue: [self refresh: var with: aSymbol. ^ self]]! ----- Method: WidgetStub>>widgetNamed: (in category 'accessing') ----- widgetNamed: aString ^ self name = aString ifTrue: [self] ifFalse: [nil]! ToolBuilder subclass: #SUnitToolBuilder instanceVariableNames: 'widgets' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! !SUnitToolBuilder commentStamp: 'cwp 6/7/2005 00:53' prior: 0! I create a set of "stub" widgets that are useful for testing. Instead of drawing themselves in some GUI, they simulate graphical widgets for testing purposes. Through my widgets, unit tests can simulate user actions and make assertions about the state of the display. See TestRunnerPlusTest for examples.! ----- Method: SUnitToolBuilder>>buildPluggableButton: (in category 'building') ----- buildPluggableButton: aSpec | w | w := ButtonStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableList: (in category 'building') ----- buildPluggableList: aSpec | w | w := ListStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableMenu: (in category 'building') ----- buildPluggableMenu: aSpec ^ MenuStub fromSpec: aSpec! ----- Method: SUnitToolBuilder>>buildPluggablePanel: (in category 'building') ----- buildPluggablePanel: aSpec | w | w := PanelStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableText: (in category 'building') ----- buildPluggableText: aSpec | w | w := TextStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableTree: (in category 'building') ----- buildPluggableTree: aSpec | w | w := TreeStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableWindow: (in category 'building') ----- buildPluggableWindow: aSpec | window children | window := WindowStub fromSpec: aSpec. children := aSpec children. children isSymbol ifFalse: [window children: (children collect: [:ea | ea buildWith: self])]. self register: window id: aSpec name. ^ window! ----- Method: SUnitToolBuilder>>close: (in category 'opening') ----- close: aWidget aWidget close! ----- Method: SUnitToolBuilder>>open: (in category 'opening') ----- open: anObject ^ self build: anObject! ----- Method: SUnitToolBuilder>>register:id: (in category 'private') ----- register: widget id: id id ifNil:[^self]. widgets ifNil:[widgets := Dictionary new]. widgets at: id put: widget.! ----- Method: SUnitToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- widgetAt: id ifAbsent: aBlock widgets ifNil:[^aBlock value]. ^widgets at: id ifAbsent: aBlock! ToolBuilderTests subclass: #SUnitToolBuilderTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: SUnitToolBuilderTests>>acceptWidgetText (in category 'support') ----- acceptWidgetText widget accept: 'Some text'! ----- Method: SUnitToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- buttonWidgetEnabled ^ widget isEnabled! ----- Method: SUnitToolBuilderTests>>changeListWidget (in category 'support') ----- changeListWidget widget clickItemAt: widget selectedIndex + 1! ----- Method: SUnitToolBuilderTests>>fireButtonWidget (in category 'support') ----- fireButtonWidget widget click! ----- Method: SUnitToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- fireMenuItemWidget widget click: 'Menu Item'! ----- Method: SUnitToolBuilderTests>>setUp (in category 'running') ----- setUp super setUp. builder := SUnitToolBuilder new.! ----- Method: SUnitToolBuilderTests>>testHandlingNotification (in category 'tests') ----- testHandlingNotification | receivedSignal resumed | receivedSignal := resumed := false. [ | count | "client-code puts up progress, and signals some notications" count := 0. 'doing something' displayProgressFrom: 0 to: 10 during: [ : bar | 10 timesRepeat: [ bar value: (count := count + 1). (Delay forMilliseconds: 200) wait. Notification signal: 'message'. resumed := true ] ] ] on: Notification do: [ : noti | receivedSignal := true. noti resume ]. self assert: receivedSignal ; assert: resumed! ----- Method: SUnitToolBuilderTests>>testListCached (in category 'tests') ----- testListCached self makeItemList. queries := Bag new. self changed: #getList. widget list. widget list. self assert: queries size = 1! ----- Method: SUnitToolBuilderTests>>testListSelectionCached (in category 'tests') ----- testListSelectionCached self makeItemList. queries := Bag new. self changed: #getListSelection. widget selectedIndex. widget selectedIndex. self assert: queries size = 1! ----- Method: SUnitToolBuilderTests>>testTextCached (in category 'tests') ----- testTextCached self makeText. queries := Bag new. self changed: #getText. widget text. widget text. self assert: queries size = 1! ----- Method: SUnitToolBuilderTests>>widgetColor (in category 'support') ----- widgetColor ^ widget color! From commits at source.squeak.org Fri Jun 5 20:14:50 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:14:56 2015 Subject: [squeak-dev] Squeak 4.6: TraitsTests-nice.14.mcz Message-ID: Chris Muller uploaded a new version of TraitsTests to project Squeak 4.6: http://source.squeak.org/squeak46/TraitsTests-nice.14.mcz ==================== Summary ==================== Name: TraitsTests-nice.14 Author: nice Time: 27 May 2014, 2:28:14.935 am UUID: 44c0f5be-a415-4f22-a8b6-856fd0bf7e79 Ancestors: TraitsTests-fbs.13 Some Traits test do timeout. Relax the constraints. ==================== Snapshot ==================== SystemOrganization addCategory: #'TraitsTests-Kernel'! TestCase subclass: #TraitsTestCase instanceVariableNames: 'createdClassesAndTraits' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! TraitsTestCase subclass: #ClassTraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: ClassTraitTest>>testChanges (in category 'testing') ----- testChanges "Test the most important features to ensure that general functionality of class traits are working." "self run: #testChanges" | classTrait | classTrait := self t1 classTrait. classTrait compile: 'm1ClassSide ^17' classified: 'mycategory'. "local selectors" self assert: (classTrait includesLocalSelector: #m1ClassSide). self deny: (classTrait includesLocalSelector: #otherSelector). "propagation" self assert: (self t5 classSide methodDict includesKey: #m1ClassSide). self assert: (self c2 class methodDict includesKey: #m1ClassSide). self assert: self c2 m1ClassSide = 17. "category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) = 'mycategory'. "conflicts" self t2 classSide compile: 'm1ClassSide' classified: 'mycategory'. self assert: (self c2 class methodDict includesKey: #m1ClassSide). self deny: (self c2 class includesLocalSelector: #m1ClassSide). self should: [self c2 m1ClassSide] raise: Error. "conflict category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) = #mycategory! ----- Method: ClassTraitTest>>testConflictsAliasesAndExclusions (in category 'testing') ----- testConflictsAliasesAndExclusions "conflict" self t1 classTrait compile: 'm2ClassSide: x ^99' classified: 'mycategory'. self assert: (self t1 classTrait includesLocalSelector: #m2ClassSide:). self assert: (self t5 classTrait >> #m2ClassSide:) isConflict. self assert: (self c2 class >> #m2ClassSide:) isConflict. "exclusion and alias" self assert: self t5 classSide traitComposition asString = 'T1 classTrait + T2 classTrait'. self t5 classSide uses: (self t1 classTrait @ { (#m2ClassSideAlias1: -> #m2ClassSide:) } + self t2 classTrait) @ { (#m2ClassSideAlias2: -> #m2ClassSide:) } - { #m2ClassSide: }. self deny: (self t5 classTrait >> #m2ClassSide:) isConflict. self deny: (self c2 class >> #m2ClassSide:) isConflict. self assert: (self c2 m2ClassSideAlias1: 13) = 99. self assert: (self c2 m2ClassSideAlias2: 13) = 13! ----- Method: ClassTraitTest>>testInitialization (in category 'testing') ----- testInitialization "self run: #testInitialization" | classTrait | classTrait := self t1 classTrait. self assert: self t1 hasClassTrait. self assert: self t1 classTrait == classTrait. self assert: classTrait isClassTrait. self assert: classTrait classSide == classTrait. self deny: classTrait isBaseTrait. self assert: classTrait baseTrait == self t1. "assert classtrait methods are propagated to users when setting traitComposition" self assert: self t4 hasClassTrait. self assert: self t5 hasClassTrait. self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:). self assert: (self t4 classSide methodDict includesKey: #m2ClassSide:). self assert: (self t5 classSide methodDict includesKey: #m2ClassSide:). self assert: (self c2 m2ClassSide: 17) = 17! ----- Method: ClassTraitTest>>testUsers (in category 'testing') ----- testUsers self assert: self t2 classSide users size = 3. self assert: (self t2 classSide users includesAllOf: { (self t4 classTrait). (self t5 classTrait). (self t6 classTrait) }). self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 uses: self t1 + self t5. self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 uses: self t2 asTraitComposition. self assert: self t5 classSide users isEmpty! TraitsTestCase subclass: #PureBehaviorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: PureBehaviorTest>>testChangeSuperclass (in category 'testing-applying trait composition') ----- testChangeSuperclass "self run: #testChangeSuperclass" "Test that when the superclass of a class is changed the non-local methods of the class sending super are recompiled to correctly store the new superclass." | aC2 newSuperclass | aC2 := self c2 new. "C1 is current superclass of C2" self assert: aC2 m51. self assert: self c2 superclass == self c1. self deny: (self c2 localSelectors includes: #m51). self deny: (self c2 >> #m52) == (self t5 >> #m52). "no sharing!!" self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo). "change superclass of C2 from C1 to X" newSuperclass := self createClassNamed: #X superclass: Object uses: {}. newSuperclass subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category. self assert: self c2 superclass == newSuperclass. newSuperclass compile: 'foo ^17'. self assert: aC2 m51 = 17. self deny: (self c2 localSelectors includes: #m51). self c2 compile: 'm51 ^19'. self assert: aC2 m51 = 19. self deny: (self c2 >> #m52) == (self t5 >> #m52). "no sharing!!" self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo m51). "change superclass of C2 back to C1" self c1 subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category. self assert: (aC2 m51 = 19). self assert: self c2 superclass == self c1. self assert: (self c2 localSelectors includes: #m51). self deny: (self c2 >> #m52) == (self t5 >> #m52). "no sharing!!" self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo m51). ! ----- Method: PureBehaviorTest>>testClassesWithTraits (in category 'testing-applying trait composition') ----- testClassesWithTraits "self debug: #testClassesWithTraits" self assert: (self c1 methodDict includesKey: #foo). self assert: (self c2 methodDict includesKey: #bar). self assert: (self c2 methodDict includesKey: #m51). self assert: (self c2 methodDict includesKey: #m12). self assert: (self c2 methodDict includesKey: #m13). self assert: (self c2 methodDict includesKey: #m21). self assert: (self c2 methodDict includesKey: #m22). self deny: self c1 class hasTraitComposition. self assert: self c2 class hasTraitComposition. self assert: (self c2 class traitComposition size = 1). self assert: (self c2 class includesTrait: self t5 classTrait)! ----- Method: PureBehaviorTest>>testIsAliasSelector (in category 'testing') ----- testIsAliasSelector self deny: (self t1 isAliasSelector: #m11). self deny: (self t1 isAliasSelector: #foo). "directly" self assert: (self t6 isAliasSelector: #m22Alias). self deny: (self t6 isAliasSelector: #m22). "indirectly" self c1 uses: self t6. self assert: (self c1 isAliasSelector: #m22Alias). self deny: (self c1 isAliasSelector: #m22)! ----- Method: PureBehaviorTest>>testIsLocalAliasSelector (in category 'testing') ----- testIsLocalAliasSelector self deny: (self t1 isLocalAliasSelector: #m11). self deny: (self t1 isLocalAliasSelector: #foo). "directly" self assert: (self t6 isLocalAliasSelector: #m22Alias). self deny: (self t6 isLocalAliasSelector: #m22). "indirectly" self c1 uses: self t6 asTraitComposition. self deny: (self c1 isLocalAliasSelector: #m22Alias). self deny: (self c1 isLocalAliasSelector: #m22)! ----- Method: PureBehaviorTest>>testLocalSelectors (in category 'testing') ----- testLocalSelectors "self run: #testLocalSelectors" self assert: self t3 localSelectors size = 3. self assert: (self t3 localSelectors includesAllOf: #(#m31 #m32 #m33 )). self assert: (self t3 includesLocalSelector: #m32). self deny: (self t3 includesLocalSelector: #inexistantSelector). self assert: self t5 localSelectors size = 3. self assert: (self t5 localSelectors includes: #m51). self assert: (self t5 includesLocalSelector: #m51). self deny: (self t5 includesLocalSelector: #m11). self t5 removeSelector: #m51. self deny: (self t3 includesLocalSelector: #m51). self deny: (self t5 includesLocalSelector: #m11). self assert: self t5 localSelectors size = 2. self t5 compile: 'm52 ^self'. self assert: self t5 localSelectors size = 2. self assert: (self t5 localSelectors includes: #m52). "test that propagated methods do not get in as local methods" self t2 compile: 'local2 ^self'. self deny: (self t5 includesLocalSelector: #local2). self assert: self t5 localSelectors size = 2. self assert: (self t5 localSelectors includes: #m52). self assert: self c2 localSelectors size = 2. self assert: (self c2 localSelectors includesAllOf: #(#foo #bar ))! ----- Method: PureBehaviorTest>>testMethodCategoryReorganization (in category 'testing') ----- testMethodCategoryReorganization "self run: #testMethodCategory" self t1 compile: 'm1' classified: 'category1'. self assert: (self t5 organization categoryOfElement: #m1) = #category1. self assert: (self c2 organization categoryOfElement: #m1) = #category1. self t1 organization classify: #m1 under: #category2 suppressIfDefault: true. self assert: (self t5 organization categoryOfElement: #m1) = #category2. self assert: (self c2 organization categoryOfElement: #m1) = #category2! ----- Method: PureBehaviorTest>>testOwnMethodsTakePrecedenceOverTraitsMethods (in category 'testing-applying trait composition') ----- testOwnMethodsTakePrecedenceOverTraitsMethods "First create a trait with no subtraits and then add subtrait t1 which implements m11 as well." | trait | trait := self createTraitNamed: #TraitsTestTrait uses: { }. trait compile: 'm11 ^999'. self assert: trait methodDict size = 1. self assert: (trait methodDict at: #m11) decompileString = 'm11 ^ 999'. self createTraitNamed: #TraitsTestTrait uses: self t1. self assert: trait methodDict size = 3. self assert: (trait methodDict keys includesAllOf: #(#m11 #m12 #m13 )). self assert: (trait methodDict at: #m11) decompileString = 'm11 ^ 999'. self assert: (trait methodDict at: #m12) decompileString = 'm12 ^ 12'! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraits (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraits | aC2 | aC2 := self c2 new. self assert: self c2 methodDict size = 9. self t1 compile: 'zork ^false'. self assert: self c2 methodDict size = 10. self deny: aC2 zork. self t1 removeSelector: #m12. self assert: self c2 methodDict size = 9. self should: [aC2 m12] raise: MessageNotUnderstood. self assert: aC2 m21 = 21. self t2 compile: 'm21 ^99'. self assert: aC2 m21 = 99! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraitsToAliasMethods (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraitsToAliasMethods | anObject | anObject := (self createClassNamed: #TraitsTestAliasTestClass superclass: Object uses: self t6) new. self assert: anObject m22Alias = 22. "test update alias method" self t2 compile: 'm22 ^17'. self assert: anObject m22Alias = 17. "removing original method should also remove alias method" self t2 removeSelector: #m22. self should: [anObject m22Alias] raise: MessageNotUnderstood! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded "Assert that alias method is updated although the original method is excluded from this user." | anObject | anObject := (self createClassNamed: #TraitsTestAliasTestClass superclass: Object uses: self t1 @ { (#aliasM11 -> #m11) } - { #m11 }) new. self assert: anObject aliasM11 = 11. self deny: (anObject class methodDict includesKey: #m11). self t1 compile: 'm11 ^17'. self assert: anObject aliasM11 = 17! ----- Method: PureBehaviorTest>>testPropagationWhenTraitCompositionModifications (in category 'testing-applying trait composition') ----- testPropagationWhenTraitCompositionModifications "Test that the propagation mechanism works when setting new traitCompositions." self assert: self c2 methodDict size = 9. "2 + (3+(3+2))-1" "removing methods" self createTraitNamed: #T5 uses: self t1 + self t2 - { #m21. #m22 }. self assert: self c2 methodDict size = 7. "adding methods" self createTraitNamed: #T2 uses: self t3. self assert: self c2 methodDict size = 10. self assert: (self c2 methodDict keys includesAllOf: #(#m31 #m32 #m33 ))! ----- Method: PureBehaviorTest>>testRemovingMethods (in category 'testing') ----- testRemovingMethods "When removing a local method, assure that the method from the trait is installed instead and that the users are updated." "self run: #testRemovingMethods" "Classes" self c2 compile: 'm12 ^0' classified: #xxx. self assert: (self c2 includesLocalSelector: #m12). self c2 removeSelector: #m12. self deny: (self c2 includesLocalSelector: #m12). self assert: (self c2 selectors includes: #m12). "Traits" self t5 compile: 'm12 ^0' classified: #xxx. self assert: self c2 new m12 = 0. self t5 removeSelector: #m12. self deny: (self t5 includesLocalSelector: #m12). self assert: (self t5 selectors includes: #m12). self assert: self c2 new m12 = 12! ----- Method: PureBehaviorTest>>testReshapeClass (in category 'testing-applying trait composition') ----- testReshapeClass "self run: #testReshapeClass" "Ensure that reshaping a class has no impact on its traits" self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo). self c2 addInstVarName: 'foobar'. self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo). self c2 removeInstVarName: 'foobar'. self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo). ! ----- Method: PureBehaviorTest>>testSuperSends (in category 'testing-applying trait composition') ----- testSuperSends | aC2 | aC2 := self c2 new. self assert: aC2 m51. self deny: aC2 foo. self deny: aC2 bar! ----- Method: PureBehaviorTest>>testTraitCompositionModifications (in category 'testing-applying trait composition') ----- testTraitCompositionModifications self assert: self t6 methodDict size = 6. self assert: (self t6 sourceCodeAt: #m22Alias) asString = 'm22Alias ^22'. self t6 uses: self t2 asTraitComposition. self assert: self t6 methodDict size = 2. self deny: (self t6 methodDict includesKey: #m22Alias). self t6 uses: self t1 @ { (#m13Alias -> #m13) } - { #m11. #m12 } + self t2. self assert: self t6 methodDict size = 4. self assert: (self t6 methodDict keys includesAllOf: #(#m13 #m13Alias #m21 #m22 )). self assert: (self t6 sourceCodeAt: #m13Alias) asString = 'm13Alias ^self m12'! ----- Method: PureBehaviorTest>>testTraitCompositionWithCycles (in category 'testing-applying trait composition') ----- testTraitCompositionWithCycles self should: [self t1 uses: self t1 asTraitComposition] raise: Error. self t2 uses: self t3 asTraitComposition. self should: [self t3 uses: self t5 asTraitComposition] raise: Error! ----- Method: PureBehaviorTest>>testUpdateWhenLocalMethodRemoved (in category 'testing-applying trait composition') ----- testUpdateWhenLocalMethodRemoved | aC2 | aC2 := self c2 new. self t5 compile: 'foo ^123'. self deny: aC2 foo. self c2 removeSelector: #foo. self assert: aC2 foo = 123! ----- Method: PureBehaviorTest>>traitOrClassOfSelector (in category 'testing') ----- traitOrClassOfSelector "self run: #traitOrClassOfSelector" "locally defined in trait or class" self assert: (self t1 >> #m12) originalTraitOrClass = self t1. self assert: (self c1 >> #foo) originalTraitOrClass = self c1. "not locally defined - simple" self assert: (self t4 >> #m21) originalTraitOrClass = self t2. self assert: (self c2 >> #m51) originalTraitOrClass = self t5. "not locally defined - into nested traits" self assert: (self c2 >> #m22) originalTraitOrClass = self t2. "not locally defined - aliases" self assert: (self t6 >> #m22Alias) originalTraitOrClass = self t2. "class side" self assert: (self t2 classSide >> #m2ClassSide:) originalTraitOrClass = self t2 classSide. self assert: (self t6 classSide >> #m2ClassSide:) originalTraitOrClass = self t2 classSide! TraitsTestCase subclass: #TraitCompositionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitCompositionTest>>testAliasCompositions (in category 'testing-basic') ----- testAliasCompositions "unary" self shouldnt: [self t2 uses: self t1 @ { (#aliasM11 -> #m11) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#alias: -> #m11) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#alias:x:y: -> #m11) }] raise: TraitCompositionException. "binary" self t1 compile: '= anObject'. self shouldnt: [self t2 uses: self t1 @ { (#equals: -> #=) }] raise: TraitCompositionException. self shouldnt: [self t2 uses: self t1 @ { (#% -> #=) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#equals -> #=) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#equals:x: -> #=) }] raise: TraitCompositionException. "keyword" self t1 compile: 'x: a y: b z: c'. self should: [self t2 uses: self t1 @ { (#'==' -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x: -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x:y: -> #x:y:z:) }] raise: TraitCompositionException. self shouldnt: [self t2 uses: self t1 @ { (#myX:y:z: -> #x:y:z:) }] raise: TraitCompositionException. "alias same as selector" self should: [self t2 uses: self t1 @ { (#m11 -> #m11) }] raise: TraitCompositionException. "same alias name used twice" self should: [self t2 uses: self t1 @ { (#alias -> #m11). (#alias -> #m12) }] raise: TraitCompositionException. "aliasing an alias" self should: [self t2 uses: self t1 @ { (#alias -> #m11). (#alias2 -> #alias) }] raise: TraitCompositionException! ----- Method: TraitCompositionTest>>testClassMethodsTakePrecedenceOverTraitsMethods (in category 'testing-enquiries') ----- testClassMethodsTakePrecedenceOverTraitsMethods | keys | keys := Set new. self t4 methodDict bindingsDo: [:each | keys add: each key]. self assert: keys size = 6. self assert: (keys includesAllOf: #( #m12 #m13 #m13 #m21 #m22 #m11 #m42 )). self assert: (self t4 methodDict at: #m11) decompileString = 'm11 ^ 41'! ----- Method: TraitCompositionTest>>testCompositionFromArray (in category 'testing-basic') ----- testCompositionFromArray | composition | composition := TraitComposition withAll: { (self t1) }. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: composition traits size = 1. composition := TraitComposition withAll: { (self t1). self t2 }. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: composition traits size = 2! ----- Method: TraitCompositionTest>>testEmptyTrait (in category 'testing-basic') ----- testEmptyTrait | composition | composition := TraitComposition withAll: {}. self assert: (composition isKindOf: TraitComposition). " self assert: composition transformations isEmpty. " self assert: composition traits isEmpty! ----- Method: TraitCompositionTest>>testInvalidComposition (in category 'testing-basic') ----- testInvalidComposition self shouldnt: [self t1 @ { (#a -> #b) } @ { (#x -> #y) }] raise: TraitCompositionException. self shouldnt: [(self t1 + self t2) @ { (#a -> #b) } @ { (#x -> #y) }] raise: TraitCompositionException. self shouldnt: [self t1 - { #a } - { #b }] raise: TraitCompositionException. self shouldnt: [self t1 + self t2 - { #a } - { #b }] raise: TraitCompositionException. self should: [(self t1 - { #x }) @ { (#a -> #b) }] raise: TraitCompositionException. self should: [(self t1 + self t2 - { #x }) @ { (#a -> #b) }] raise: TraitCompositionException. self should: [self t1 + self t1] raise: TraitCompositionException. self should: [(self t1 + self t2) @ { (#a -> #b) } + self t1] raise: TraitCompositionException. self should: [self t1 @ { (#a -> #m11). (#a -> #m12) }] raise: TraitCompositionException. self should: [self t1 @ { (#a -> #m11). (#b -> #a) }] raise: TraitCompositionException! ----- Method: TraitCompositionTest>>testPrinting (in category 'testing-basic') ----- testPrinting | composition1 composition2 | composition1 := ((self t1 - { #a } + self t2) @ { (#z -> #c) } - { #b. #c } + self t3 - { #d. #e } + self t4) @ { (#x -> #a). (#y -> #b) }. composition2 := self t4 @ { (#x -> #a). (#y -> #b) } + self t1 - { #a } + self t3 - { #d. #e } + self t2 - { #b. #c }. self assertPrints: composition1 printString like: 'T1 - {#a} + T2 @ {#z->#c} - {#b. #c} + T3 - {#d. #e} + T4 @ {#x->#a. #y->#b}'. self assertPrints: composition2 printString like: 'T4 @ {#x->#a. #y->#b} + T1 - {#a} + T3 - {#d. #e} + T2 - {#b. #c}'! ----- Method: TraitCompositionTest>>testProvidedMethodBindingsWithConflicts (in category 'testing-enquiries') ----- testProvidedMethodBindingsWithConflicts | traitWithConflict methodDict | traitWithConflict := self createTraitNamed: #TraitsTestTraitWithConflict uses: self t1 + self t4. methodDict := traitWithConflict methodDict. self assert: methodDict size = 6. self assert: (methodDict keys includesAllOf: #( #m11 #m12 #m13 #m21 #m22 #m42 )). self assert: (methodDict at: #m11) decompileString = 'm11 ^ self traitConflict'! ----- Method: TraitCompositionTest>>testSum (in category 'testing-basic') ----- testSum | composition | composition := self t1 + self t2 + self t3. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: (composition traits includes: self t3). self assert: composition traits size = 3! ----- Method: TraitCompositionTest>>testSumWithParenthesis (in category 'testing-basic') ----- testSumWithParenthesis | composition | composition := self t1 + (self t2 + self t3). self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: (composition traits includes: self t3). self assert: composition traits size = 3. self assert: composition size = 3! TraitsTestCase subclass: #TraitFileOutTest instanceVariableNames: 'ca cb ta tb tc td' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitFileOutTest>>categoryName (in category 'running') ----- categoryName ^'TraitsTests-FileOut'! ----- Method: TraitFileOutTest>>fileIn: (in category 'testing') ----- fileIn: fileName | prior file result | prior := ClassDescription traitImpl. [ ClassDescription traitImpl: Trait. file := FileStream readOnlyFileNamed: fileName. result := file fileIn ] ensure: [ file ifNotNil:[file close]. ClassDescription traitImpl: prior. ]. ^result! ----- Method: TraitFileOutTest>>setUp (in category 'running') ----- setUp super setUp. SystemOrganization addCategory: self categoryName. td := self createTraitNamed: #TD uses: {}. td compile: 'd' classified: #cat1. tc := self createTraitNamed: #TC uses: td. tc compile: 'c' classified: #cat1. tb := self createTraitNamed: #TB uses: td. tb compile: 'b' classified: #cat1. ta := self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}. ta compile: 'a' classified: #cat1. ca := self createClassNamed: #CA superclass: Object uses: {}. ca compile: 'ca' classified: #cat1. cb := self createClassNamed: #CB superclass: ca uses: ta. cb compile: 'cb' classified: #cat1. "make the class of cb also use tc:" cb class uses: ta classTrait + tc instanceVariableNames: ''.! ----- Method: TraitFileOutTest>>tearDown (in category 'running') ----- tearDown | dir | dir := FileDirectory default. self createdClassesAndTraits, self resourceClassesAndTraits do: [:each | dir deleteFileNamed: each asString , '.st' ifAbsent: []]. dir deleteFileNamed: self categoryName , '.st' ifAbsent: []. SystemOrganization removeSystemCategory: self categoryName. ca := cb := ta := tb := tc := td := nil. super tearDown! ----- Method: TraitFileOutTest>>testCondenseChanges (in category 'testing') ----- testCondenseChanges "Tests moveChangesTo: in the face of aliases and other trait manipulations" | file classOrTrait originals copy | file := FileStream forceNewFileNamed: 'TraitFileOutTest.changes'. [originals := IdentityDictionary new. #(t1 t2 t3 t4 t5 t6 c1 c2) do:[:clsName| classOrTrait := self perform: clsName. classOrTrait methodsDo:[:each| originals at: each put: each getSourceFromFile. ]. file setToEnd. classOrTrait moveChangesTo: file. originals keysAndValuesDo:[:method :source| "we need the upfront assertion to avoid a current bug in #nextChunk when using out of bounds indexes" self assert: method filePosition < file size. copy := file position: method filePosition; nextChunkText. self assert: copy = source. ]. ]. ] ensure:[ TraitsResource current setDirty. file close. FileDirectory default deleteFileNamed: file name ifAbsent:[]. ].! ----- Method: TraitFileOutTest>>testFileOutCategory (in category 'testing') ----- testFileOutCategory "File out whole system category, delete all classes and traits and then file them in again." "self run: #testFileOutCategory" SystemOrganization fileOutCategory: self categoryName. SystemOrganization removeSystemCategory: self categoryName. self deny: (Smalltalk globals keys includesAnyOf: #(CA CB TA TB TC TD)). self fileIn: self categoryName , '.st'.. self assert: (Smalltalk globals keys includesAllOf: #(CA CB TA TB TC TD)). ta := Smalltalk at: #TA. self assert: (ta isKindOf: Trait). self assert: 'TB + TC @ {#cc->#c} - {#c}' equals: ta traitComposition asString. self assert: (ta methodDict keys includesAllOf: #(a b cc)). cb := Smalltalk at: #CB. self assert: (cb isKindOf: Class). self assert: 'TA' equals: cb traitComposition asString. self assert: (cb methodDict keys includesAllOf: #(cb a b cc)). "test classSide traitComposition of CB" self assert: 'TA classTrait + TC' equals: cb classSide traitComposition asString. self assert: (cb classSide methodDict keys includesAllOf: #(d c)) ! ----- Method: TraitFileOutTest>>testFileOutTrait (in category 'testing') ----- testFileOutTrait "fileOut trait T6, remove it from system and then file it in again" "self run: #testFileOutTrait" | fileName | self t6 compile: 'localMethod: argument ^argument'. self t6 classSide compile: 'localClassSideMethod: argument ^argument'. self t6 fileOut. fileName := self t6 asString , '.st'. self resourceClassesAndTraits remove: self t6. self t6 removeFromSystem. self fileIn: fileName. self assert: (Smalltalk includesKey: #T6). TraitsResource current t6: (Smalltalk at: #T6). self resourceClassesAndTraits add: self t6. self assert: (self t6 isKindOf: Trait). self assert: 'T1 + T2 @ {#m22Alias->#m22}' equals: self t6 traitComposition asString. self assert: (self t6 methodDict keys includesAllOf: #( #localMethod: #m11 #m12 #m13 #m21 #m22 #m22Alias )). self assert: 2 equals: self t6 classSide methodDict size. self assert: (self t6 classSide methodDict keys includes: #localClassSideMethod:) description: 'Missing selector #localClassSideMethod:'. self assert: (self t6 classSide methodDict keys includes: #m2ClassSide:) description: 'Missing selector #m2ClassSide:'.! ----- Method: TraitFileOutTest>>testRemovingMethods (in category 'testing') ----- testRemovingMethods "When removing a local method, assure that the method from the trait is installed instead and that the users are updated." "self run: #testRemovingMethods" "Classes" self c2 compile: 'm12 ^0' classified: #xxx. self assert: (self c2 includesLocalSelector: #m12). self c2 removeSelector: #m12. self deny: (self c2 includesLocalSelector: #m12). self assert: (self c2 selectors includes: #m12). "Traits" self t5 compile: 'm12 ^0' classified: #xxx. self assert: self c2 new m12 = 0. self t5 removeSelector: #m12. self deny: (self t5 includesLocalSelector: #m12). self assert: (self t5 selectors includes: #m12). self assert: self c2 new m12 = 12! TraitsTestCase subclass: #TraitMethodDescriptionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitMethodDescriptionTest>>testArgumentNames (in category 'running') ----- testArgumentNames self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: myArgument zork2: somethingElse ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2'). self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: somethingElse zork2: myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2')! ----- Method: TraitMethodDescriptionTest>>testCategories (in category 'running') ----- testCategories self assert: (self t4 organization categoryOfElement: #m21) = #cat1. self assert: (self t4 organization categoryOfElement: #m22) = #cat2. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t4 organization categoryOfElement: #m12) = #cat2. self assert: (self t4 organization categoryOfElement: #m13) = #cat3. self assert: (self t6 organization categoryOfElement: #m22Alias) = #cat2. self t2 organization classify: #m22 under: #catX. self assert: (self t4 organization categoryOfElement: #m22) = #catX. self assert: (self t6 organization categoryOfElement: #m22Alias) = #catX. self t6 organization classify: #m22 under: #catY. self t6 organization classify: #m22Alias under: #catY. self t2 organization classify: #m22 under: #catZ. "XXX: The following test is commented out for now. The policy is to *always* reclassify the method if the base method is reclassified. That results from the requirement that the base construction should always be repeatable (in fact, one could argue that reclassification of methods from traits is invalid without some explicit transformation)." false ifTrue:[ self assert: (self t6 organization categoryOfElement: #m22) = #catY. self assert: (self t6 organization categoryOfElement: #m22Alias) = #catY. ]. self t1 compile: 'mA' classified: #catA. self assert: (self t4 organization categoryOfElement: #mA) = #catA. self t1 organization classify: #mA under: #cat1. self assert: (self t4 organization categories includes: #catA) not! ----- Method: TraitMethodDescriptionTest>>testConflictMethodCreation (in category 'running') ----- testConflictMethodCreation "Generate conflicting methods between t1 and t2 and check the resulting method in Trait t5 (or c2). Also test selectors like foo:x (without space) or selectors with CRs." "unary" self t2 compile: 'm12 ^false'. self assert: ((self t5 sourceCodeAt: #m12) asString beginsWith: 'm12'). self should: [self c2 new m12] raise: Error. "binary" self t1 compile: '@ myArgument ^true'. self t2 compile: '@myArgument ^false'. self assert: ((self t5 sourceCodeAt: #@) asString beginsWith: '@ arg1'). self should: [self c2 new @ 17] raise: Error. "keyword" self t1 compile: 'zork: myArgument ^true'. self t2 compile: 'zork: myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork:) asString beginsWith: 'zork: arg1'). self should: [self c2 new zork: 17] raise: Error. self t1 compile: 'zork:myArgument ^true'. self t2 compile: 'zork:myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork:) asString beginsWith: 'zork: arg1'). self should: [self c2 new zork: 17] raise: Error. self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: anObject zork2: anotherObject ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2'). self should: [self c2 new zork1: 1 zork2: 2] raise: Error! ----- Method: TraitMethodDescriptionTest>>testConflictingCategories (in category 'running') ----- testConflictingCategories | t7 t8 | self t2 compile: 'm11' classified: #catY. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #'conflict methods'. "was: #cat1" t7 := self createTraitNamed: #T7 uses: self t1 + self t2. self assert: (t7 organization categoryOfElement: #m11) = #'conflict methods'. "was: ClassOrganizer ambiguous" self t1 removeSelector: #m11. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #catY. self assert: (t7 organization categoryOfElement: #m11) = #catY. self deny: (t7 organization categories includes: #'conflict methods' "was: ClassOrganizer ambiguous"). self t1 compile: 'm11' classified: #cat1. t8 := self createTraitNamed: #T8 uses: self t1 + self t2. t8 organization classify: #m11 under: #cat1. self t1 organization classify: #m11 under: #catZ. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #'conflict methods'. "was: #catY" self assert: (t8 organization categoryOfElement: #m11) = #'conflict methods'. "was: #catZ"! TraitsTestCase subclass: #TraitSystemTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitSystemTest>>testAllClassesAndTraits (in category 'testing') ----- testAllClassesAndTraits "self debug: #testAllClassesAndTraits" | trait | trait := self t1. self assert: (Smalltalk allClassesAndTraits includes: trait). self deny: (Smalltalk allClasses includes: trait). ! ----- Method: TraitSystemTest>>testAllImplementedMessagesWithout (in category 'testing') ----- testAllImplementedMessagesWithout "self debug: #testAllImplementedMessagesWithout" self t6 compile: 'das2qwdqwd'. self assert: (SystemNavigation default allImplementedMessages includes: #das2qwdqwd). self deny: (SystemNavigation default allImplementedMessages includes: #qwdqwdqwdc).! ----- Method: TraitSystemTest>>testAllSentMessages (in category 'testing') ----- testAllSentMessages "self debug: #testAllSentMessages" self t1 compile: 'foo 1 dasoia'. self assert: (SystemNavigation default allSentMessages includes: 'dasoia' asSymbol). self deny: (SystemNavigation default allSentMessages includes: 'nioaosi' asSymbol).! TraitsTestCase subclass: #TraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitTest>>testAddAndRemoveMethodsFromSubtraits (in category 'testing') ----- testAddAndRemoveMethodsFromSubtraits | aC2 | aC2 := self c2 new. self assert: aC2 m51. self t5 removeSelector: #m51. self should: [aC2 m51] raise: MessageNotUnderstood. self t1 compile: 'foo ^true'. self deny: aC2 foo. self t1 compile: 'm51 ^self'. self shouldnt: [aC2 m51] raise: MessageNotUnderstood. self assert: aC2 m51 == aC2! ----- Method: TraitTest>>testAddAndRemoveMethodsInClassOrTrait (in category 'testing') ----- testAddAndRemoveMethodsInClassOrTrait | aC2 | aC2 := self c2 new. self assert: aC2 m51. self c2 compile: 'm51 ^123'. self assert: aC2 m51 = 123. self c2 removeSelector: #m51. self shouldnt: [aC2 m51] raise: MessageNotUnderstood. self assert: aC2 m51. self t4 removeSelector: #m11. self assert: (self t4 methodDict includesKey: #m11)! ----- Method: TraitTest>>testAllClassVarNames (in category 'testing') ----- testAllClassVarNames self assert: self t1 allClassVarNames isEmpty! ----- Method: TraitTest>>testCompositionCopy (in category 'testing') ----- testCompositionCopy | t6compositionCopyFirst c2compositionCopy | self assert: (self t1 + self t2) allTraits = (self t1 + self t2) copyTraitExpression allTraits. self assert: (self t1 classTrait + self t2 classTrait) allTraits = (self t1 classTrait + self t2 classTrait) copyTraitExpression allTraits. self assert: self t6 traitComposition allTraits = self t6 traitComposition copyTraitExpression allTraits. self assert: self t6 asTraitComposition copyTraitExpression allTraits = { (self t1). (self t2). (self t6) }. "make no undue sharing happens of exclusions and aliases after an expression copy" t6compositionCopyFirst := self t6 traitComposition copyTraitExpression. t6compositionCopyFirst at: 1 put: #m22Alias -> #m33. self assert: self t6 traitComposition second aliases first value = #m22. c2compositionCopy := self c2 traitComposition copyTraitExpression. c2compositionCopy first exclusions add: #m4. self assert: self c2 traitComposition first exclusions = #(#m11) asSet.! ----- Method: TraitTest>>testExplicitRequirement (in category 'testing') ----- testExplicitRequirement "self run: #testExplicitRequirement" self t1 compile: 'm self explicitRequirement'. self t2 compile: 'm ^true'. self deny: (self t4 >> #m) == (self t2 >> #m). "no sharing!!" self assert: self c2 new m. self t2 removeSelector: #m. self deny: (self t5 >> #m) == (self t1 >> #m). "no sharing!!" self should: [self c2 new m] raise: Error! ----- Method: TraitTest>>testMarkerMethods (in category 'testing') ----- testMarkerMethods "self debug: #testMarkerMethods" self t1 compile: 'm1 self foo bar'. self assert: (self t1 >> #m1) markerOrNil isNil. self t1 compile: 'm2 self requirement'. self assert: (self t1 >> #m2) markerOrNil == #requirement. self t1 compile: 'm3 ^self requirement'. self assert: (self t1 >> #m3) markerOrNil == #requirement.! ----- Method: TraitTest>>testPrinting (in category 'testing') ----- testPrinting self assertPrints: self t6 definition like: 'Trait named: #T6 uses: T1 + T2 @ {#m22Alias->#m22} category: ''TraitsTests-Kernel'''! ----- Method: TraitTest>>testPrintingClassSide (in category 'testing') ----- testPrintingClassSide "self run: #testPrintingClassSide" self assertPrints: self t6 classSide definition like: 'T6 classTrait uses: T1 classTrait + T2 classTrait'! ----- Method: TraitTest>>testRemoveFromSystem (in category 'testing') ----- testRemoveFromSystem self t4 removeFromSystem. self deny: (Smalltalk includesKey: #T4). self assert: self t4 name = 'AnObsoleteT4'. self assert: self t4 methodDict isEmpty. self deny: (self t1 users includes: self t4)! ----- Method: TraitTest>>testRequirement (in category 'testing') ----- testRequirement "self run: #testRequirement" self t1 compile: 'm self requirement'. self t2 compile: 'm ^true'. self deny: (self t4 >> #m) == (self t2 >> #m). "no sharing!!" self assert: self c2 new m. self t2 removeSelector: #m. self deny: (self t5 >> #m) == (self t1 >> #m). "no sharing!!" self should: [self c2 new m] raise: Error! ----- Method: TraitTest>>testTraitFromPattern (in category 'testing') ----- testTraitFromPattern | newTrait | newTrait := self createTraitNamed: #TTraitTestBaseTrait uses: {}. self assert: (UIManager default classFromPattern: 'TTraitTestBaseT' withCaption: '') = newTrait.! ----- Method: TraitTest>>testTraitMethodClass (in category 'testing') ----- testTraitMethodClass "Tests that the #methodClass of a trait method isn't screwed up" | baseTrait classA methodA classB methodB traitMethod | baseTrait := self createTraitNamed: #TraitTestBaseTrait uses:{}. baseTrait compileSilently: 'traitMethod' classified: 'tests'. traitMethod := baseTrait compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. classA := self createClassNamed: #TraitTestMethodClassA superclass: Object uses: baseTrait. methodA := classA compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. self assert: methodA methodClass == classA. classB := self createClassNamed: #TraitTestMethodClassB superclass: Object uses: baseTrait. methodB := classB compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. self assert: methodA methodClass == classA. self assert: methodB methodClass == classB.! ----- Method: TraitTest>>testTraitMethodSelector (in category 'testing') ----- testTraitMethodSelector "Tests that the #selector of a trait method isn't screwed up when aliasing traits" | baseTrait classA methodA classB methodB traitMethod | baseTrait := self createTraitNamed: #TraitTestBaseTrait uses:{}. baseTrait compileSilently: 'traitMethod' classified: 'tests'. traitMethod := baseTrait compiledMethodAt: #traitMethod. self assert: traitMethod selector == #traitMethod. classA := self createClassNamed: #TraitTestMethodClassA superclass: Object uses: {baseTrait @ {#methodA -> #traitMethod}}. methodA := classA compiledMethodAt: #methodA. self assert: traitMethod selector == #traitMethod. self assert: methodA selector == #methodA. classB := self createClassNamed: #TraitTestMethodClassB superclass: Object uses: {baseTrait @ {#methodB -> #traitMethod}}. methodB := classB compiledMethodAt: #methodB. self assert: traitMethod selector == #traitMethod. self assert: methodA selector == #methodA. self assert: methodB selector == #methodB.! ----- Method: TraitTest>>testUsers (in category 'testing') ----- testUsers self assert: self t1 users size = 3. self assert: (self t1 users includesAllOf: {self t4. self t5. self t6 }). self assert: self t3 users isEmpty. self assert: self t5 users size = 1. self assert: self t5 users anyOne = self c2. self c2 uses: self t1 + self t5. self assert: self t5 users size = 1. self assert: self t5 users anyOne = self c2. self c2 uses: self t2 asTraitComposition. self assert: self t5 users isEmpty! ----- Method: TraitsTestCase class>>resources (in category 'as yet unclassified') ----- resources ^{TraitsResource}! ----- Method: TraitsTestCase>>assertPrints:like: (in category 'utility') ----- assertPrints: aString like: anotherString self assert: (aString copyWithout: $ ) = (anotherString copyWithout: $ )! ----- Method: TraitsTestCase>>c1 (in category 'accessing') ----- c1 ^TraitsResource current c1! ----- Method: TraitsTestCase>>c2 (in category 'accessing') ----- c2 ^TraitsResource current c2! ----- Method: TraitsTestCase>>c3 (in category 'accessing') ----- c3 ^TraitsResource current c3! ----- Method: TraitsTestCase>>c4 (in category 'accessing') ----- c4 ^TraitsResource current c4! ----- Method: TraitsTestCase>>c5 (in category 'accessing') ----- c5 ^TraitsResource current c5! ----- Method: TraitsTestCase>>c6 (in category 'accessing') ----- c6 ^TraitsResource current c6! ----- Method: TraitsTestCase>>c7 (in category 'accessing') ----- c7 ^TraitsResource current c7! ----- Method: TraitsTestCase>>c8 (in category 'accessing') ----- c8 ^TraitsResource current c8! ----- Method: TraitsTestCase>>categoryName (in category 'running') ----- categoryName ^self class category! ----- Method: TraitsTestCase>>createClassNamed:superclass:uses: (in category 'utility') ----- createClassNamed: aSymbol superclass: aClass uses: aTraitComposition | class | class := aClass subclass: aSymbol uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryName. self createdClassesAndTraits add: class. ^class! ----- Method: TraitsTestCase>>createTraitNamed:uses: (in category 'utility') ----- createTraitNamed: aSymbol uses: aTraitComposition | trait | trait := Trait named: aSymbol uses: aTraitComposition category: self categoryName env: Smalltalk globals. self createdClassesAndTraits add: trait. ^trait! ----- Method: TraitsTestCase>>createdClassesAndTraits (in category 'utility') ----- createdClassesAndTraits createdClassesAndTraits ifNil: [ createdClassesAndTraits := OrderedCollection new]. ^createdClassesAndTraits! ----- Method: TraitsTestCase>>resourceClassesAndTraits (in category 'utility') ----- resourceClassesAndTraits ^TraitsResource current createdClassesAndTraits! ----- Method: TraitsTestCase>>t1 (in category 'accessing') ----- t1 ^TraitsResource current t1! ----- Method: TraitsTestCase>>t2 (in category 'accessing') ----- t2 ^TraitsResource current t2! ----- Method: TraitsTestCase>>t3 (in category 'accessing') ----- t3 ^TraitsResource current t3! ----- Method: TraitsTestCase>>t4 (in category 'accessing') ----- t4 ^TraitsResource current t4! ----- Method: TraitsTestCase>>t5 (in category 'accessing') ----- t5 ^TraitsResource current t5! ----- Method: TraitsTestCase>>t6 (in category 'accessing') ----- t6 ^TraitsResource current t6! ----- Method: TraitsTestCase>>tearDown (in category 'running') ----- tearDown TraitsResource resetIfDirty. self createdClassesAndTraits do: [:aClassOrTrait | | behaviorName | behaviorName := aClassOrTrait name. Smalltalk at: behaviorName ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. ChangeSet current removeClassChanges: behaviorName]. createdClassesAndTraits := nil! TestResource subclass: #TraitsResource instanceVariableNames: 'createdClassesAndTraits t1 t2 t3 t4 t5 t6 c1 c2 c3 c4 c5 c6 c7 c8 dirty' classVariableNames: 'SetUpCount' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitsResource class>>resetIfDirty (in category 'as yet unclassified') ----- resetIfDirty self current isDirty ifTrue: [self reset]! ----- Method: TraitsResource>>c1 (in category 'accessing') ----- c1 ^c1! ----- Method: TraitsResource>>c1: (in category 'accessing') ----- c1: anObject ^c1 := anObject! ----- Method: TraitsResource>>c2 (in category 'accessing') ----- c2 ^c2! ----- Method: TraitsResource>>c2: (in category 'accessing') ----- c2: anObject ^c2 := anObject! ----- Method: TraitsResource>>c3 (in category 'accessing') ----- c3 ^c3! ----- Method: TraitsResource>>c3: (in category 'accessing') ----- c3: anObject ^c3 := anObject! ----- Method: TraitsResource>>c4 (in category 'accessing') ----- c4 ^c4! ----- Method: TraitsResource>>c4: (in category 'accessing') ----- c4: anObject ^c4 := anObject! ----- Method: TraitsResource>>c5 (in category 'accessing') ----- c5 ^c5! ----- Method: TraitsResource>>c5: (in category 'accessing') ----- c5: anObject ^c5 := anObject! ----- Method: TraitsResource>>c6 (in category 'accessing') ----- c6 ^c6! ----- Method: TraitsResource>>c6: (in category 'accessing') ----- c6: anObject ^c6 := anObject! ----- Method: TraitsResource>>c7 (in category 'accessing') ----- c7 ^c7! ----- Method: TraitsResource>>c7: (in category 'accessing') ----- c7: anObject ^c7 := anObject! ----- Method: TraitsResource>>c8 (in category 'accessing') ----- c8 ^c8! ----- Method: TraitsResource>>c8: (in category 'accessing') ----- c8: anObject ^c8 := anObject! ----- Method: TraitsResource>>categoryName (in category 'as yet unclassified') ----- categoryName ^self class category! ----- Method: TraitsResource>>codeChangedEvent: (in category 'as yet unclassified') ----- codeChangedEvent: anEvent (anEvent isDoIt not and: [anEvent itemClass notNil and: [self createdClassesAndTraits includes: anEvent itemClass instanceSide]]) ifTrue: [self setDirty] ! ----- Method: TraitsResource>>createClassNamed:superclass:uses: (in category 'as yet unclassified') ----- createClassNamed: aSymbol superclass: aClass uses: aTraitComposition | class | class := aClass subclass: aSymbol uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryName. self createdClassesAndTraits add: class. ^class! ----- Method: TraitsResource>>createTraitNamed:uses: (in category 'as yet unclassified') ----- createTraitNamed: aSymbol uses: aTraitComposition | trait | trait := Trait named: aSymbol uses: aTraitComposition category: self categoryName env: Smalltalk globals. self createdClassesAndTraits add: trait. ^trait! ----- Method: TraitsResource>>createdClassesAndTraits (in category 'as yet unclassified') ----- createdClassesAndTraits createdClassesAndTraits ifNil: [ createdClassesAndTraits := OrderedCollection new]. ^createdClassesAndTraits! ----- Method: TraitsResource>>isDirty (in category 'accessing') ----- isDirty ^dirty! ----- Method: TraitsResource>>setDirty (in category 'accessing') ----- setDirty dirty := true! ----- Method: TraitsResource>>setUp (in category 'as yet unclassified') ----- setUp "Please note, that most tests rely on this setup of traits and classes - and that especially the order of the definitions matters." "SetUpCount := SetUpCount + 1." dirty := false. SystemChangeNotifier uniqueInstance doSilently: [self t1: (self createTraitNamed: #T1 uses: { }). self t1 comment: 'I am the trait T1'. self t2: (self createTraitNamed: #T2 uses: { }). self t2 compile: 'm21 ^21' classified: #cat1. self t2 compile: 'm22 ^22' classified: #cat2. self t2 classSide compile: 'm2ClassSide: a ^a'. self t3: (self createTraitNamed: #T3 uses: { }). self t3 compile: 'm31 ^31' classified: #cat1. self t3 compile: 'm32 ^32' classified: #cat2. self t3 compile: 'm33 ^33' classified: #cat3. self t4: (self createTraitNamed: #T4 uses: { (self t1). (self t2) }). self t4 compile: 'm11 ^41' classified: #catX. "overrides T1>>m11" self t4 compile: 'm42 ^42' classified: #cat2. self t5: (self createTraitNamed: #T5 uses: self t1 + self t2). self t5 compile: 'm51 ^super foo' classified: #cat1. self t5 compile: 'm52 ^ self class bar' classified: #cat1. self t5 compile: 'm53 ^ self class bar' classified: #cat1. self t6: (self createTraitNamed: #T6 uses: (self t1 + self t2) @ { (#m22Alias -> #m22) }). self c1: (self createClassNamed: #C1 superclass: Object uses: { }). self c1 compile: 'foo ^true' classified: #accessing. self t1 compile: 'm11 ^11' classified: #cat1. self t1 compile: 'm12 ^12' classified: #cat2. self t1 compile: 'm13 ^self m12' classified: #cat3. self c2: (self createClassNamed: #C2 superclass: self c1 uses: self t5 - { #m11 }). self c2 compile: 'foo ^false' classified: #private. self c2 compile: 'bar ^self foo' classified: #private. self setUpTrivialRequiresFixture. self setUpTwoLevelRequiresFixture. self setUpTranslatingRequiresFixture]. SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #codeChangedEvent:! ----- Method: TraitsResource>>setUpTranslatingRequiresFixture (in category 'as yet unclassified') ----- setUpTranslatingRequiresFixture self c6: (self createClassNamed: #C6 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c6. self c6 superclass: nil. self c7: (self createClassNamed: #C7 superclass: self c6 uses: { }). self c8: (self createClassNamed: #C8 superclass: self c7 uses: { }). self c6 compile: 'foo ^self x' classified: #accessing. self c7 compile: 'foo ^3' classified: #accessing. self c7 compile: 'bar ^super foo' classified: #accessing. self c8 compile: 'bar ^self blah' classified: #accessing! ----- Method: TraitsResource>>setUpTrivialRequiresFixture (in category 'as yet unclassified') ----- setUpTrivialRequiresFixture self c3: (self createClassNamed: #C3 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c3. self c3 superclass: nil. self c3 compile: 'foo ^self bla' classified: #accessing! ----- Method: TraitsResource>>setUpTwoLevelRequiresFixture (in category 'as yet unclassified') ----- setUpTwoLevelRequiresFixture self c4: (self createClassNamed: #C4 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c4. self c4 superclass: nil. self c5: (self createClassNamed: #C5 superclass: self c4 uses: { }). self c4 compile: 'foo ^self blew' classified: #accessing. self c5 compile: 'foo ^self blah' classified: #accessing! ----- Method: TraitsResource>>t1 (in category 'accessing') ----- t1 ^t1! ----- Method: TraitsResource>>t1: (in category 'accessing') ----- t1: anObject ^t1 := anObject! ----- Method: TraitsResource>>t2 (in category 'accessing') ----- t2 ^t2! ----- Method: TraitsResource>>t2: (in category 'accessing') ----- t2: anObject ^t2 := anObject! ----- Method: TraitsResource>>t3 (in category 'accessing') ----- t3 ^t3! ----- Method: TraitsResource>>t3: (in category 'accessing') ----- t3: anObject ^t3 := anObject! ----- Method: TraitsResource>>t4 (in category 'accessing') ----- t4 ^t4! ----- Method: TraitsResource>>t4: (in category 'accessing') ----- t4: anObject ^t4 := anObject! ----- Method: TraitsResource>>t5 (in category 'accessing') ----- t5 ^t5! ----- Method: TraitsResource>>t5: (in category 'accessing') ----- t5: anObject ^t5 := anObject! ----- Method: TraitsResource>>t6 (in category 'accessing') ----- t6 ^t6! ----- Method: TraitsResource>>t6: (in category 'accessing') ----- t6: anObject ^t6 := anObject! ----- Method: TraitsResource>>tearDown (in category 'as yet unclassified') ----- tearDown SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. self createdClassesAndTraits do: [:aClassOrTrait | | behaviorName | behaviorName := aClassOrTrait name. Smalltalk at: behaviorName ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. ChangeSet current removeClassChanges: behaviorName]. createdClassesAndTraits := self t1: (self t2: (self t3: (self t4: (self t5: (self t6: (self c1: (self c2: (self c3: (self c4: (self c5: (self c6: (self c7: (self c8: nil)))))))))))))! From commits at source.squeak.org Fri Jun 5 20:15:28 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:15:31 2015 Subject: [squeak-dev] Squeak 4.6: SUnit-mt.102.mcz Message-ID: Chris Muller uploaded a new version of SUnit to project Squeak 4.6: http://source.squeak.org/squeak46/SUnit-mt.102.mcz ==================== Summary ==================== Name: SUnit-mt.102 Author: mt Time: 19 April 2015, 7:24:35.203 am UUID: 3e115dcf-b404-3043-814e-ecb6f43f9192 Ancestors: SUnit-bf.101 Extracted logic of being a test method to be easier reusable in extensions and tools. Moved test-class-check from SUnitTools to here. ==================== Snapshot ==================== SystemOrganization addCategory: #'SUnit-Extensions'! SystemOrganization addCategory: #'SUnit-Kernel'! SystemOrganization addCategory: #'SUnit-Tests'! ----- Method: CompiledMethod>>isTestMethod (in category '*SUnit-testing') ----- isTestMethod ^ self methodClass isTestClass and: [self selector isTestSelector]! Exception subclass: #TestFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! !TestFailure commentStamp: '' prior: 0! Signaled in case of a failed test (failure). The test framework distinguishes between failures and errors. A failure is anticipated and checked for with assertions. Errors are unanticipated problems like a division by 0 or an index out of bounds ...! TestFailure subclass: #ResumableTestFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! !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. ! ----- Method: ResumableTestFailure>>isResumable (in category 'camp smalltalk') ----- isResumable "Of course a ResumableTestFailure is resumable ;-)" ^true! ----- Method: ResumableTestFailure>>sunitExitWith: (in category 'camp smalltalk') ----- sunitExitWith: aValue self resume: aValue! ----- Method: TestFailure>>defaultAction (in category 'camp smalltalk') ----- defaultAction Processor activeProcess debug: self signalerContext title: self description! ----- Method: TestFailure>>isResumable (in category 'camp smalltalk') ----- isResumable ^ false! ----- Method: MethodReference>>isTestMethod (in category '*SUnit-testing') ----- isTestMethod ^ self compiledMethod isTestMethod! ----- Method: Symbol>>isTestSelector (in category '*SUnit-testing') ----- isTestSelector ^ self beginsWith: 'test'! Object subclass: #ClassFactoryForTestCase instanceVariableNames: 'createdClasses' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Extensions'! ----- Method: ClassFactoryForTestCase>>cleanUp (in category 'cleaning') ----- cleanUp | createdClassNames | createdClassNames := self createdClassNames. self deleteClasses. self deletePackage. self cleanUpChangeSetForClassNames: createdClassNames. self createdClasses: IdentitySet new! ----- Method: ClassFactoryForTestCase>>cleanUpChangeSetForClassNames: (in category 'cleaning') ----- cleanUpChangeSetForClassNames: classeNames | changeSet | changeSet := ChangeSet current. classeNames do: [:name| changeSet removeClassChanges: name; removeClassChanges: name, ' class']. ! ----- Method: ClassFactoryForTestCase>>createdClassNames (in category 'accessing') ----- createdClassNames ^self createdClasses collect: [:class| class name]! ----- Method: ClassFactoryForTestCase>>createdClasses (in category 'accessing') ----- createdClasses ^createdClasses! ----- Method: ClassFactoryForTestCase>>createdClasses: (in category 'accessing') ----- createdClasses: classes createdClasses := classes asIdentitySet ! ----- Method: ClassFactoryForTestCase>>defaultCategory (in category 'accessing') ----- defaultCategory ^ (self packageName , '-', self defaultCategoryPostfix) asSymbol! ----- Method: ClassFactoryForTestCase>>defaultCategoryPostfix (in category 'accessing') ----- defaultCategoryPostfix ^ #Default! ----- Method: ClassFactoryForTestCase>>delete: (in category 'cleaning') ----- delete: aClass aClass isObsolete ifTrue: [^self]. aClass removeFromChanges. aClass removeFromSystemUnlogged ! ----- Method: ClassFactoryForTestCase>>deleteClasses (in category 'cleaning') ----- deleteClasses self createdClasses do: [:class| self delete: class]! ----- Method: ClassFactoryForTestCase>>deletePackage (in category 'cleaning') ----- deletePackage | categoriesMatchString | categoriesMatchString := self packageName, '-*'. SystemOrganization removeCategoriesMatching: categoriesMatchString! ----- Method: ClassFactoryForTestCase>>initialize (in category 'cleaning') ----- initialize super initialize. self createdClasses: IdentitySet new! ----- Method: ClassFactoryForTestCase>>newClass (in category 'creating') ----- newClass ^self newSubclassOf: Object instanceVariableNames: '' classVariableNames: ''! ----- Method: ClassFactoryForTestCase>>newClassInCategory: (in category 'creating') ----- newClassInCategory: category ^self newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: category! ----- Method: ClassFactoryForTestCase>>newName (in category 'creating') ----- newName | postFix | postFix := (self createdClasses size + 1) printString. ^#ClassForTestToBeDeleted, postFix! ----- Method: ClassFactoryForTestCase>>newSubclassOf:instanceVariableNames:classVariableNames: (in category 'creating') ----- newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^self newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: self defaultCategoryPostfix! ----- Method: ClassFactoryForTestCase>>newSubclassOf:instanceVariableNames:classVariableNames:category: (in category 'creating') ----- newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | newClass := aClass subclass: self newName asSymbol instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: (self packageName, '-', category) asSymbol. self createdClasses add: newClass. ^newClass! ----- Method: ClassFactoryForTestCase>>packageName (in category 'accessing') ----- packageName ^#CategoryForTestToBeDeleted! ----- Method: Object>>isTestClass (in category '*SUnit-testing') ----- isTestClass ^ false! Object subclass: #TestCase instanceVariableNames: 'testSelector timeout' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! TestCase class instanceVariableNames: 'history'! !TestCase 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.! TestCase class instanceVariableNames: 'history'! TestCase subclass: #ClassFactoryForTestCaseTest instanceVariableNames: 'factory' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: ClassFactoryForTestCaseTest class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testDefaultCategoryCleanUp; add: #testPackageCleanUp; add: #testSingleClassCreation; add: #testClassCreationInDifferentCategories; add: #testClassFastCreationInDifferentCategories; add: #testMultipleClassCreation; add: #testSingleClassFastCreation; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: ClassFactoryForTestCaseTest>>setUp (in category 'setUp-tearDown') ----- setUp super setUp. factory := ClassFactoryForTestCase new! ----- Method: ClassFactoryForTestCaseTest>>tearDown (in category 'setUp-tearDown') ----- tearDown super tearDown. factory cleanUp! ----- Method: ClassFactoryForTestCaseTest>>testClassCreationInDifferentCategories (in category 'testing') ----- testClassCreationInDifferentCategories | firstThreeClasses lastTwoClasses | 3 timesRepeat: [ factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #One]. firstThreeClasses := factory createdClasses copy. 2 timesRepeat: [ factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #Two]. lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]). self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).! ----- Method: ClassFactoryForTestCaseTest>>testClassFastCreationInDifferentCategories (in category 'testing') ----- testClassFastCreationInDifferentCategories | firstThreeClasses lastTwoClasses | 3 timesRepeat: [ factory newClassInCategory: #One]. firstThreeClasses := factory createdClasses copy. 2 timesRepeat: [ factory newClassInCategory: #Two]. lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]). self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).! ----- Method: ClassFactoryForTestCaseTest>>testDefaultCategoryCleanUp (in category 'testing') ----- testDefaultCategoryCleanUp | createdClassNames allClasses | 3 timesRepeat: [ factory newClass]. createdClassNames := factory createdClassNames. factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). allClasses := SystemNavigation new allClasses. self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). self deny: (SystemOrganization categories includes: factory defaultCategory). self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) ! ----- Method: ClassFactoryForTestCaseTest>>testMultipleClassCreation (in category 'testing') ----- testMultipleClassCreation 5 timesRepeat: [ factory newClass]. self assert: (SystemNavigation new allClasses includesAllOf: factory createdClasses). self assert: factory createdClassNames asSet size = 5. self assert: (SystemOrganization listAtCategoryNamed: factory defaultCategory) asSet = factory createdClassNames asSet! ----- Method: ClassFactoryForTestCaseTest>>testPackageCleanUp (in category 'testing') ----- testPackageCleanUp | createdClassNames allClasses | 3 timesRepeat: [ factory newClassInCategory: #One]. 2 timesRepeat: [ factory newClassInCategory: #Two]. createdClassNames := factory createdClassNames. factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). allClasses := SystemNavigation new allClasses. self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). self assert: (SystemOrganization categoriesMatching: factory packageName, '*') isEmpty. self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) ! ----- Method: ClassFactoryForTestCaseTest>>testSingleClassCreation (in category 'testing') ----- testSingleClassCreation |class elementsInCategoryForTest | class := factory newSubclassOf: Object instanceVariableNames: 'a b c' classVariableNames: 'X Y'. self assert: (SystemNavigation new allClasses includes: class). elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory. self assert: elementsInCategoryForTest = {class name}. self assert: class instVarNames = #(a b c). self assert: class classPool keys asSet = #(X Y) asSet! ----- Method: ClassFactoryForTestCaseTest>>testSingleClassFastCreation (in category 'testing') ----- testSingleClassFastCreation |class elementsInCategoryForTest | class := factory newClass. self assert: (SystemNavigation new allClasses includes: class). elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory. self assert: elementsInCategoryForTest = {class name}. self assert: class instVarNames isEmpty. self assert: class classPool isEmpty! TestCase subclass: #ClassTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Extensions'! !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. ! ----- Method: ClassTestCase class>>isAbstract (in category 'Testing') ----- isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self name = #ClassTestCase ! ----- Method: ClassTestCase class>>mustTestCoverage (in category 'Testing') ----- mustTestCoverage ^ false! ----- Method: ClassTestCase>>categoriesForClass: (in category 'private') ----- categoriesForClass: aClass ^ aClass organization allMethodSelectors collect: [:each | aClass organization categoryOfElement: each]. ! ----- Method: ClassTestCase>>classToBeTested (in category 'coverage') ----- classToBeTested self subclassResponsibility! ----- Method: ClassTestCase>>selectorsNotTested (in category 'coverage') ----- selectorsNotTested ^ self selectorsToBeTested difference: self selectorsTested. ! ----- Method: ClassTestCase>>selectorsTested (in category 'Coverage') ----- selectorsTested | literals | literals := Set new. self class selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test') ifTrue: [ literals addAll: (m messages)] ]. ^ literals asSortedArray! ----- Method: ClassTestCase>>selectorsToBeIgnored (in category 'coverage') ----- selectorsToBeIgnored ^ #(#DoIt #DoItIn:)! ----- Method: ClassTestCase>>selectorsToBeTested (in category 'coverage') ----- selectorsToBeTested ^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors]) difference: self selectorsToBeIgnored! ----- Method: ClassTestCase>>targetClass (in category 'private') ----- targetClass |className| className := self class name asText copyFrom: 0 to: self class name size - 4. ^ Smalltalk at: (className asString asSymbol). ! ----- Method: ClassTestCase>>testClassComment (in category 'tests') ----- testClassComment self shouldnt: [self targetClass organization hasNoComment].! ----- Method: ClassTestCase>>testCoverage (in category 'tests') ----- testCoverage | untested | self class mustTestCoverage ifTrue: [ untested := self selectorsNotTested. self assert: untested isEmpty description: untested size asString, ' selectors are not covered' ]! ----- Method: ClassTestCase>>testNew (in category 'tests') ----- testNew "This should not throw an exception." self targetClass new.! ----- Method: ClassTestCase>>testUnCategorizedMethods (in category 'tests') ----- testUnCategorizedMethods | categories slips uncategorisedMethods | categories := self categoriesForClass: self targetClass. slips := categories select: [:each | each = #'as yet unclassified']. uncategorisedMethods := self targetClass organization listAtCategoryNamed: #'as yet unclassified'. self assert: slips isEmpty description: ('{1} has uncategorised methods: {2}' format: {self targetClass. (uncategorisedMethods collect: #printString) asCommaString}).! TestCase subclass: #LongTestCase instanceVariableNames: '' classVariableNames: 'ShouldRun' poolDictionaries: '' category: 'SUnit-Extensions'! !LongTestCase commentStamp: 'ul 12/15/2009 13:06' prior: 0! A LongTestCase is a TestCase that usually takes a long time to run. Because of this users can decide if they want to execute these or not, by changing the "Run long test cases" preference.! ----- Method: LongTestCase class>>allTestSelectors (in category 'accessing') ----- allTestSelectors self shouldRun ifTrue: [ ^super testSelectors ]. ^#().! ----- Method: LongTestCase class>>buildSuite (in category 'instance creation') ----- buildSuite self shouldRun ifTrue: [ ^super buildSuite ]. ^self suiteClass new! ----- Method: LongTestCase class>>doNotRunLongTestCases (in category 'accessing') ----- doNotRunLongTestCases self shouldRun: false! ----- Method: LongTestCase class>>isAbstract (in category 'testing') ----- isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self name == #LongTestCase ! ----- Method: LongTestCase class>>runLongTestCases (in category 'accessing') ----- runLongTestCases self shouldRun: true! ----- Method: LongTestCase class>>shouldRun (in category 'accessing') ----- shouldRun ^ShouldRun ifNil: [ true ]! ----- Method: LongTestCase class>>shouldRun: (in category 'accessing') ----- shouldRun: aBoolean ShouldRun := aBoolean! ----- Method: LongTestCase>>defaultTimeout (in category 'as yet unclassified') ----- defaultTimeout "Answer the default timeout to use for tests in this test case. The timeout is a value in seconds." ^super defaultTimeout * 10! LongTestCase subclass: #LongTestCaseTestUnderTest instanceVariableNames: '' classVariableNames: 'RunStatus' poolDictionaries: '' category: 'SUnit-Extensions'! ----- Method: LongTestCaseTestUnderTest class>>hasRun (in category 'accessing') ----- hasRun ^ RunStatus! ----- Method: LongTestCaseTestUnderTest class>>markAsNotRun (in category 'accessing') ----- markAsNotRun ^ RunStatus := false! ----- Method: LongTestCaseTestUnderTest>>testWhenRunMarkTestedToTrue (in category 'testing') ----- testWhenRunMarkTestedToTrue RunStatus := true.! TestCase subclass: #LongTestCaseTest instanceVariableNames: 'preferenceValue' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Extensions'! ----- Method: LongTestCaseTest>>setUp (in category 'as yet unclassified') ----- setUp preferenceValue := LongTestCase shouldRun! ----- Method: LongTestCaseTest>>tearDown (in category 'as yet unclassified') ----- tearDown LongTestCase shouldRun: preferenceValue! ----- Method: LongTestCaseTest>>testLongTestCaseDoNotRun (in category 'testing') ----- testLongTestCaseDoNotRun "self debug: #testLongTestCaseDoNotRun" "self run: #testLongTestCaseDoNotRun" LongTestCase doNotRunLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self deny: LongTestCaseTestUnderTest hasRun. ! ----- Method: LongTestCaseTest>>testLongTestCaseRun (in category 'testing') ----- testLongTestCaseRun "self debug: #testLongTestCaseRun" "self run: #testLongTestCaseRun" LongTestCase runLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self assert: LongTestCaseTestUnderTest hasRun. LongTestCase doNotRunLongTestCases. ! TestCase subclass: #ResumableTestFailureTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: ResumableTestFailureTestCase class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testResumable; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: ResumableTestFailureTestCase>>errorTest (in category 'not categorized') ----- errorTest 1 zork ! ----- Method: ResumableTestFailureTestCase>>failureTest (in category '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 ! ----- Method: ResumableTestFailureTestCase>>okTest (in category 'not categorized') ----- okTest self assert: true ! ----- Method: ResumableTestFailureTestCase>>regularTestFailureTest (in category 'not categorized') ----- regularTestFailureTest self assert: false description: 'You should see me' ! ----- Method: ResumableTestFailureTestCase>>resumableTestFailureTest (in category '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 ! ----- Method: ResumableTestFailureTestCase>>testResumable (in category '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 ! TestCase subclass: #SUnitExtensionsTest instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: SUnitExtensionsTest class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testNoExceptionWithMatchingString; add: #testNoExceptionWithNoMatchingString; add: #testExceptionWithMatchingString; add: #testExceptionWithoutMatchingString; add: #testValidShouldNotTakeMoreThan; add: #testInvalidShouldNotTakeMoreThanMilliseconds; add: #testDifferentExceptionInShouldRaiseWithExceptionDo; add: #testShouldRaiseWithExceptionDo; add: #testShouldFix; add: #testAssertionFailedInRaiseWithExceptionDo; add: #testAutoDenyFalse; add: #testAutoDenyTrue; add: #testAutoAssertFalse; add: #testAutoAssertTrue; add: #testValidShouldNotTakeMoreThanMilliseconds; add: #testErrorInRaiseWithExceptionDo; add: #testNoExceptionInShouldRaiseWithExceptionDo; add: #testInvalidShouldNotTakeMoreThan; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: SUnitExtensionsTest>>assertionFailedInRaiseWithExceptionDoTest (in category 'real tests') ----- assertionFailedInRaiseWithExceptionDoTest self should: [ Error signal ] raise: Error withExceptionDo: [ :anException | self assert: false ]! ----- Method: SUnitExtensionsTest>>differentExceptionInShouldRaiseWithExceptionDoTest (in category 'real tests') ----- differentExceptionInShouldRaiseWithExceptionDoTest [ self should: [ Error signal ] raise: Halt withExceptionDo: [ :anException | self assert: false description: 'should:raise:withExceptionDo: handled an exception that should not handle'] ] on: Error do: [ :anException | anException return: nil ]! ----- Method: SUnitExtensionsTest>>errorInRaiseWithExceptionDoTest (in category 'real tests') ----- errorInRaiseWithExceptionDoTest self should: [ Error signal ] raise: Error withExceptionDo: [ :anException | Error signal: 'A forced error' ]! ----- Method: SUnitExtensionsTest>>failureLog (in category 'test support') ----- failureLog ^self stream! ----- Method: SUnitExtensionsTest>>invalidShouldNotTakeMoreThan (in category 'real tests') ----- invalidShouldNotTakeMoreThan self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 50 milliSeconds.! ----- Method: SUnitExtensionsTest>>invalidShouldNotTakeMoreThanMilliseconds (in category 'real tests') ----- invalidShouldNotTakeMoreThanMilliseconds self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 50! ----- Method: SUnitExtensionsTest>>isLogging (in category 'testing') ----- isLogging ^true! ----- Method: SUnitExtensionsTest>>noExceptionInShouldRaiseWithExceptionDoTest (in category 'real tests') ----- noExceptionInShouldRaiseWithExceptionDoTest self should: [ ] raise: Error withExceptionDo: [ :anException | Error signal: 'Should not get here' ]! ----- Method: SUnitExtensionsTest>>shouldFixTest (in category 'real tests') ----- shouldFixTest self shouldFix: [ Error signal: 'any kind of error' ] ! ----- Method: SUnitExtensionsTest>>shouldRaiseWithExceptionDoTest (in category 'real tests') ----- shouldRaiseWithExceptionDoTest self should: [ Error signal: '1' ] raise: Error withExceptionDo: [ :anException | self assert: anException messageText = '1' ]! ----- Method: SUnitExtensionsTest>>shouldRaiseWithSignalDoTest (in category 'real tests') ----- shouldRaiseWithSignalDoTest self should: [ Error signal: '1' ] raise: Error withExceptionDo: [ :anException | self assert: anException messageText = '1' ]! ----- Method: SUnitExtensionsTest>>stream (in category 'accessing') ----- stream ^stream ifNil: [stream := WriteStream on: String new]! ----- Method: SUnitExtensionsTest>>testAssertionFailedInRaiseWithExceptionDo (in category 'test') ----- testAssertionFailedInRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #assertionFailedInRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult failures includes: testCase). self assert: testResult failures size=1. self assert: testResult passed isEmpty. self assert: testResult errors isEmpty. ! ----- Method: SUnitExtensionsTest>>testAutoAssertFalse (in category 'test') ----- testAutoAssertFalse | booleanCondition | self assert: self isLogging. self should: [ self assert: 1 = 2 description: 'self assert: 1 = 2' ] raise: TestResult failure. booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self assert: 1 = 2'. self assert: booleanCondition! ----- Method: SUnitExtensionsTest>>testAutoAssertTrue (in category 'test') ----- testAutoAssertTrue self assert: 1 = 1. self assert: true! ----- Method: SUnitExtensionsTest>>testAutoDenyFalse (in category 'test') ----- testAutoDenyFalse | booleanCondition | self assert: self isLogging. self should: [ self deny: 1 = 1 description: 'self deny: 1 = 1'.] raise: TestResult failure. booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self deny: 1 = 1'. self assert: booleanCondition! ----- Method: SUnitExtensionsTest>>testAutoDenyTrue (in category 'test') ----- testAutoDenyTrue self deny: 1 = 2. self deny: false! ----- Method: SUnitExtensionsTest>>testDifferentExceptionInShouldRaiseWithExceptionDo (in category 'test') ----- testDifferentExceptionInShouldRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #differentExceptionInShouldRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult errors isEmpty. self assert: testResult failures isEmpty. self assert: testResult passed size=1! ----- Method: SUnitExtensionsTest>>testErrorInRaiseWithExceptionDo (in category 'test') ----- testErrorInRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #errorInRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult errors includes: testCase). self assert: testResult errors size=1. self assert: testResult failures isEmpty. self assert: testResult passed isEmpty. ! ----- Method: SUnitExtensionsTest>>testExceptionWithMatchingString (in category 'as yet unclassified') ----- testExceptionWithMatchingString self should: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'NOT obsolete' description: 'tested obsoleting Object'! ----- Method: SUnitExtensionsTest>>testExceptionWithoutMatchingString (in category 'as yet unclassified') ----- testExceptionWithoutMatchingString self should: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'Zero' description: 'tested obsoleting Object'! ----- Method: SUnitExtensionsTest>>testInvalidShouldNotTakeMoreThan (in category 'test') ----- testInvalidShouldNotTakeMoreThan | testCase testResult | testCase := self class selector: #invalidShouldNotTakeMoreThan. testResult := testCase run. self assert: testResult passed isEmpty. self assert: testResult failures size = 1. self assert: (testResult failures includes: testCase). self assert: testResult errors isEmpty ! ----- Method: SUnitExtensionsTest>>testInvalidShouldNotTakeMoreThanMilliseconds (in category 'test') ----- testInvalidShouldNotTakeMoreThanMilliseconds | testCase testResult | testCase := self class selector: #invalidShouldNotTakeMoreThanMilliseconds. testResult := testCase run. self assert: testResult passed isEmpty. self assert: testResult failures size = 1. self assert: (testResult failures includes: testCase). self assert: testResult errors isEmpty ! ----- Method: SUnitExtensionsTest>>testNoExceptionInShouldRaiseWithExceptionDo (in category 'test') ----- testNoExceptionInShouldRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #noExceptionInShouldRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult failures includes: testCase). self assert: testResult failures size=1. self assert: testResult passed isEmpty. self assert: testResult errors isEmpty. ! ----- Method: SUnitExtensionsTest>>testNoExceptionWithMatchingString (in category 'as yet unclassified') ----- testNoExceptionWithMatchingString self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'Zero' description: 'tested obsoleting Object'! ----- Method: SUnitExtensionsTest>>testNoExceptionWithNoMatchingString (in category 'as yet unclassified') ----- testNoExceptionWithNoMatchingString self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'NOT' description: 'tested obsoleting Object'! ----- Method: SUnitExtensionsTest>>testShouldFix (in category 'test') ----- testShouldFix | testCase testResult | testCase := self class selector: #shouldFixTest. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult passed size=1. self assert: testResult failures isEmpty. self assert: testResult errors isEmpty. ! ----- Method: SUnitExtensionsTest>>testShouldRaiseWithExceptionDo (in category 'test') ----- testShouldRaiseWithExceptionDo | testCase testResult | testCase := self class selector: #shouldRaiseWithExceptionDoTest. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult passed size=1. self assert: testResult failures isEmpty. self assert: testResult errors isEmpty. ! ----- Method: SUnitExtensionsTest>>testValidShouldNotTakeMoreThan (in category 'test') ----- testValidShouldNotTakeMoreThan | testCase testResult | testCase := self class selector: #validShouldNotTakeMoreThan. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult passed size = 1. self assert: testResult failures isEmpty. self assert: testResult errors isEmpty ! ----- Method: SUnitExtensionsTest>>testValidShouldNotTakeMoreThanMilliseconds (in category 'test') ----- testValidShouldNotTakeMoreThanMilliseconds | testCase testResult | testCase := self class selector: #validShouldNotTakeMoreThanMilliseconds. testResult := testCase run. self assert: (testResult passed includes: testCase). self assert: testResult passed size = 1. self assert: testResult failures isEmpty. self assert: testResult errors isEmpty ! ----- Method: SUnitExtensionsTest>>validShouldNotTakeMoreThan (in category 'real tests') ----- validShouldNotTakeMoreThan self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 200 milliSeconds.! ----- Method: SUnitExtensionsTest>>validShouldNotTakeMoreThanMilliseconds (in category 'real tests') ----- validShouldNotTakeMoreThanMilliseconds self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 200! TestCase subclass: #SUnitTest instanceVariableNames: 'hasRun hasSetup hasRanOnce' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! !SUnitTest commentStamp: '' prior: 0! This is both an example of writing tests and a self test for the SUnit. The tests here are pretty strange, since you want to make sure things blow up. You should not generally have to write tests this complicated in structure, although they will be far more complicated in terms of your own objects- more assertions, more complicated setup. Kent says: "Never forget, however, that if the tests are hard to write, something is probably wrong with the design".! ----- Method: SUnitTest class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testWithExceptionDo; add: #testRan; add: #testAssert; add: #testRanOnlyOnce; add: #testDialectLocalizedException; add: #testFail; add: #testDefects; add: #testIsNotRerunOnDebug; add: #testResult; add: #testRunning; add: #testError; add: #testException; add: #testShould; add: #testSuite; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: SUnitTest>>assertForTestResult:runCount:passed:failed:errors: (in category 'private') ----- assertForTestResult: aResult runCount: aRunCount passed: aPassedCount failed: aFailureCount errors: anErrorCount self assert: aResult runCount = aRunCount; assert: aResult passedCount = aPassedCount; assert: aResult failureCount = aFailureCount; assert: aResult errorCount = anErrorCount ! ----- Method: SUnitTest>>error (in category 'private') ----- error 3 zork ! ----- Method: SUnitTest>>errorShouldntRaise (in category 'testing') ----- errorShouldntRaise self shouldnt: [self someMessageThatIsntUnderstood] raise: Notification new ! ----- Method: SUnitTest>>fail (in category 'private') ----- fail self assert: false ! ----- Method: SUnitTest>>hasRun (in category 'accessing') ----- hasRun ^hasRun ! ----- Method: SUnitTest>>hasSetup (in category 'accessing') ----- hasSetup ^hasSetup ! ----- Method: SUnitTest>>noop (in category 'private') ----- noop ! ----- Method: SUnitTest>>setRun (in category 'private') ----- setRun hasRun := true ! ----- Method: SUnitTest>>setUp (in category 'running') ----- setUp hasSetup := true ! ----- Method: SUnitTest>>testAssert (in category 'testing') ----- testAssert self assert: true. self deny: false ! ----- Method: SUnitTest>>testAssertIdentical (in category 'testing') ----- testAssertIdentical | a b | a := 'foo'. b := 'bar'. self should: [self assert: a identical: b] raise: TestFailure. [self assert: a identical: b] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubString: a) description: 'Error message doesn''t include the expected value'. self assert: (error includesSubString: b) description: 'Error message doesn''t include the expected value'].! ----- Method: SUnitTest>>testAssertIdenticalDescription (in category 'testing') ----- testAssertIdenticalDescription | a b | a := 'foo'. b := a copy. self should: [self assert: a identical: b description: 'A desciption'] raise: TestFailure. [self assert: a identical: b description: 'A desciption'] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubString: 'A desciption') description: 'Error message doesn''t give you the description'].! ----- Method: SUnitTest>>testAssertIdenticalWithEqualObjects (in category 'testing') ----- testAssertIdenticalWithEqualObjects | a b | a := 'foo'. b := a copy. self should: [self assert: a identical: b] raise: TestFailure. [self assert: a identical: b] on: TestFailure do: [:e | |error| error := e messageText. self assert: (error includesSubString: 'not identical') description: 'Error message doesn''t say the two things aren''t identical'].! ----- Method: SUnitTest>>testDefects (in category 'testing') ----- testDefects | result suite error failure | suite := TestSuite new. suite addTest: (error := self class selector: #error). suite addTest: (failure := self class selector: #fail). result := suite run. self assert: result defects asArray = (Array with: error with: failure). self assertForTestResult: result runCount: 2 passed: 0 failed: 1 errors: 1 ! ----- Method: SUnitTest>>testDialectLocalizedException (in category 'testing') ----- testDialectLocalizedException self should: [TestResult signalFailureWith: 'Foo'] raise: TestResult failure. self should: [TestResult signalErrorWith: 'Foo'] raise: TestResult error. ! ----- Method: SUnitTest>>testError (in category 'testing') ----- testError | case result | case := self class selector: #error. result := case run. self assertForTestResult: result runCount: 1 passed: 0 failed: 0 errors: 1. case := self class selector: #errorShouldntRaise. result := case run. self assertForTestResult: result runCount: 1 passed: 0 failed: 0 errors: 1 ! ----- Method: SUnitTest>>testException (in category 'testing') ----- testException self should: [self error: 'foo'] raise: TestResult error ! ----- Method: SUnitTest>>testFail (in category 'testing') ----- testFail | case result | case := self class selector: #fail. result := case run. self assertForTestResult: result runCount: 1 passed: 0 failed: 1 errors: 0 ! ----- Method: SUnitTest>>testRan (in category 'testing') ----- testRan | case | case := self class selector: #setRun. case run. self assert: case hasSetup. self assert: case hasRun ! ----- Method: SUnitTest>>testRanOnlyOnce (in category 'testing') ----- testRanOnlyOnce self assert: hasRanOnce ~= true. hasRanOnce := true ! ----- Method: SUnitTest>>testResult (in category 'testing') ----- testResult | case result | case := self class selector: #noop. result := case run. self assertForTestResult: result runCount: 1 passed: 1 failed: 0 errors: 0 ! ----- Method: SUnitTest>>testRunning (in category 'testing') ----- testRunning (Delay forSeconds: 2) wait ! ----- Method: SUnitTest>>testSelectorWithArg: (in category 'testing') ----- testSelectorWithArg: anObject "should not result in error"! ----- Method: SUnitTest>>testShould (in category 'testing') ----- testShould self should: [true]; shouldnt: [false] ! ----- Method: SUnitTest>>testSuite (in category 'testing') ----- testSuite | suite result | suite := TestSuite new. suite addTest: (self class selector: #noop); addTest: (self class selector: #fail); addTest: (self class selector: #error). result := suite run. self assertForTestResult: result runCount: 3 passed: 1 failed: 1 errors: 1 ! ----- Method: SUnitTest>>testTestTimeout (in category 'testing') ----- testTestTimeout self should:[(Delay forSeconds: 6) wait] raise: TestFailure. ! ----- Method: SUnitTest>>testTestTimeoutLoop (in category 'testing') ----- testTestTimeoutLoop self should:[[] repeat] raise: TestFailure. ! ----- Method: SUnitTest>>testTestTimeoutTag (in category 'testing') ----- testTestTimeoutTag self should:[(Delay forSeconds: 3) wait] raise: TestFailure. ! ----- Method: SUnitTest>>testWithExceptionDo (in category 'testing') ----- testWithExceptionDo self should: [self error: 'foo'] raise: TestResult error withExceptionDo: [:exception | self assert: (exception description includesSubString: 'foo') ] ! TestCase subclass: #SimpleTestResourceTestCase instanceVariableNames: 'resource' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: SimpleTestResourceTestCase class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testResourceInitRelease; add: #testResourcesCollection; add: #testRan; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ----- Method: SimpleTestResourceTestCase class>>resources (in category 'not categorized') ----- resources ^Set new add: SimpleTestResource; yourself ! ----- Method: SimpleTestResourceTestCase>>dummy (in category 'not categorized') ----- dummy self assert: true ! ----- Method: SimpleTestResourceTestCase>>error (in category 'not categorized') ----- error 'foo' odd ! ----- Method: SimpleTestResourceTestCase>>fail (in category 'not categorized') ----- fail self assert: false ! ----- Method: SimpleTestResourceTestCase>>setRun (in category 'not categorized') ----- setRun resource setRun ! ----- Method: SimpleTestResourceTestCase>>setUp (in category 'not categorized') ----- setUp resource := SimpleTestResource current ! ----- Method: SimpleTestResourceTestCase>>testRan (in category 'not categorized') ----- testRan | case | case := self class selector: #setRun. case run. self assert: resource hasSetup. self assert: resource hasRun ! ----- Method: SimpleTestResourceTestCase>>testResourceInitRelease (in category 'not categorized') ----- testResourceInitRelease | result suite error failure | suite := TestSuite new. suite addTest: (error := self class selector: #error). suite addTest: (failure := self class selector: #fail). suite addTest: (self class selector: #dummy). result := suite run. self assert: resource hasSetup ! ----- Method: SimpleTestResourceTestCase>>testResourcesCollection (in category 'not categorized') ----- testResourcesCollection | collection | collection := self resources. self assert: collection size = 1 ! ----- Method: TestCase class>>addTestsFor:toSuite: (in category 'building suites') ----- addTestsFor: classNameString toSuite: suite | cls | cls := Smalltalk at: classNameString ifAbsent: [ ^suite ]. ^cls isAbstract ifTrue: [ cls allSubclasses do: [ :each | each isAbstract ifFalse: [ each addToSuiteFromSelectors: suite ] ]. suite] ifFalse: [ cls addToSuiteFromSelectors: suite ] ! ----- Method: TestCase class>>addToSuite:fromMethods: (in category 'building suites') ----- addToSuite: suite fromMethods: testMethods testMethods do: [ :selector | suite addTest: (self selector: selector) ]. ^suite! ----- Method: TestCase class>>addToSuiteFromSelectors: (in category 'building suites') ----- addToSuiteFromSelectors: suite ^self addToSuite: suite fromMethods: (self shouldInheritSelectors ifTrue: [ self allTestSelectors ] ifFalse: [self testSelectors ])! ----- Method: TestCase class>>allTestSelectors (in category 'accessing') ----- allTestSelectors ^(self allSelectors asArray select: [ :each | each isTestSelector and: [ each numArgs isZero ] ]) sort ! ----- Method: TestCase class>>buildSuite (in category 'building suites') ----- buildSuite | suite | suite := self suiteClass new. ^ self isAbstract ifTrue: [ suite name: self name asString. self allSubclasses do: [:each | each isAbstract ifFalse: [each addToSuiteFromSelectors: suite]]. suite] ifFalse: [self addToSuiteFromSelectors: suite]! ----- Method: TestCase class>>buildSuiteFromAllSelectors (in category 'building suites') ----- buildSuiteFromAllSelectors ^self buildSuiteFromMethods: self allTestSelectors ! ----- Method: TestCase class>>buildSuiteFromLocalSelectors (in category 'building suites') ----- buildSuiteFromLocalSelectors ^self buildSuiteFromMethods: self testSelectors ! ----- Method: TestCase class>>buildSuiteFromMethods: (in category 'building suites') ----- buildSuiteFromMethods: testMethods | suite | suite := (self suiteClass new) name: self name asString; yourself. ^self addToSuite: suite fromMethods: testMethods! ----- Method: TestCase class>>buildSuiteFromSelectors (in category 'building suites') ----- buildSuiteFromSelectors ^self shouldInheritSelectors ifTrue: [self buildSuiteFromAllSelectors] ifFalse: [self buildSuiteFromLocalSelectors] ! ----- Method: TestCase class>>coverage (in category 'coverage') ----- coverage "returns the coverage determined by a simple static analysis of test coverage made by the receiver on a class that is identified by the name of the receiver. We assume that SetTest test Set." | cls className | (self name endsWith: 'Test') ifFalse: [self error: 'Please, use #coverageForClass: instead']. className := self name copyFrom: 1 to: (self name size - 'Test' size). cls := Smalltalk at: className asSymbol ifAbsent: [self error: 'Please, use #coverageForClass: instead']. "May happen with Transcript" cls isBehavior ifFalse: [cls := cls class]. ^ self coverageForClass: cls! ----- Method: TestCase class>>coverageAsString (in category 'coverage') ----- coverageAsString | cov className | cov := self coverage first asInteger. "coverage already checks that the name is ends with 'Test' and if the class tested exists" className := self name copyFrom: 1 to: (self name size - 'Test' size). ^ self name asString, ' covers ', cov asString, '% of ', className.! ----- Method: TestCase class>>coverageForClass: (in category 'coverage') ----- coverageForClass: cls "returns the test coverage of all the methods included inherited ones" ^ self coverageForClass: cls until: ProtoObject! ----- Method: TestCase class>>coverageForClass:until: (in category 'coverage') ----- coverageForClass: cls until: aRootClass "returns the test coverage of all the methods included inherited ones but stopping at aRootClass included" | definedMethods testedMethods untestedMethods | definedMethods := cls allSelectorsAboveUntil: aRootClass. definedMethods size = 0 ifTrue: [^ {0. Set new}]. testedMethods := self methodDictionary inject: Set new into: [:sums :cm | sums union: cm messages]. testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not]. untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not]. ^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods} ! ----- Method: TestCase class>>coveragePercentage (in category 'coverage') ----- coveragePercentage ^ self coverage first! ----- Method: TestCase class>>debug: (in category 'instance creation') ----- debug: aSymbol ^(self selector: aSymbol) debug ! ----- Method: TestCase class>>generateLastStoredRunMethod (in category 'history') ----- generateLastStoredRunMethod self shouldGenerateLastStoredRunMethod ifTrue: [ self class compile: (self lastRunMethodNamed: #lastStoredRun) classified: 'history' ]! ----- Method: TestCase class>>hasMethodBeenRun: (in category 'testing') ----- hasMethodBeenRun: aSelector ^ ((self lastRun at: #errors), (self lastRun at: #failures), (self lastRun at: #passed)) includes: aSelector! ----- Method: TestCase class>>history (in category 'history') ----- history ^ history ifNil: [ history := self newTestDictionary ]! ----- Method: TestCase class>>history: (in category 'history') ----- history: aDictionary history := aDictionary! ----- Method: TestCase class>>initialize (in category 'initialize - event') ----- initialize super initialize. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #method using: #methodChanged:.! ----- Method: TestCase class>>isAbstract (in category 'testing') ----- isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self name = #TestCase ! ----- Method: TestCase class>>isTestClass (in category 'testing') ----- isTestClass ^ true! ----- Method: TestCase class>>lastRun (in category 'history') ----- lastRun ^ TestResult historyFor: self! ----- Method: TestCase class>>lastRunMethodNamed: (in category 'history') ----- lastRunMethodNamed: aSelector ^ String streamContents: [:str | str nextPutAll: aSelector asString ;cr. str tab; nextPutAll: '^ ', (self lastRun) storeString] ! ----- Method: TestCase class>>lastStoredRun (in category 'history') ----- lastStoredRun ^ ((Dictionary new) add: (#failures->#()); add: (#passed->#()); add: (#errors->#()); yourself)! ----- Method: TestCase class>>localCoverage (in category 'coverage') ----- localCoverage "returns the coverage determined by a simple static analysis of test coverage made by the receiver on a class that is identified by the name of the receiver. We assume that SetTest test Set. The computation of the coverage takes only into account the methods defined locally in the tested class. See coverage for a more global coverage" | cls className | (self name endsWith: 'Test') ifFalse: [self error: 'Please, use #localCoverageForClass: instead']. className := self name copyFrom: 1 to: (self name size - 'Test' size). cls := Smalltalk at: className asSymbol ifAbsent: [self error: 'Please, use #localCoverageForClass: instead']. cls isBehavior ifFalse: [cls := cls class]. ^ self localCoverageForClass: cls! ----- Method: TestCase class>>localCoverageAsString (in category 'coverage') ----- localCoverageAsString | cov className | cov := self localCoverage first asInteger. "coverage already checks that the name is ends with 'Test' and if the class tested exists" className := self name copyFrom: 1 to: (self name size - 'Test' size). ^ self name asString, ' covers ', cov asString, '% of ', className.! ----- Method: TestCase class>>localCoverageForClass: (in category 'coverage') ----- localCoverageForClass: cls | definedMethods testedMethods untestedMethods | definedMethods := cls selectors asSet. "It happens for IdentityBag / IdentityBagTest" definedMethods size = 0 ifTrue: [^ {0. Set new}]. testedMethods := self methodDictionary inject: Set new into: [:sums :cm | sums union: cm messages]. "testedMethods contains all the methods send in test methods, which probably contains methods that have nothign to do with collection" testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not]. untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not]. ^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods} ! ----- Method: TestCase class>>localCoveragePercentage (in category 'coverage') ----- localCoveragePercentage ^ self localCoverage first! ----- Method: TestCase class>>methodChanged: (in category 'initialize - event') ----- methodChanged: anEvent "Remove the changed method from the known test results." | cls sel | anEvent item isCompiledMethod ifFalse: [ ^ self ]. cls := anEvent item methodClass. (cls inheritsFrom: TestCase) ifFalse: [^ self]. sel := anEvent item selector. (sel beginsWith: 'test') ifFalse: [^ self]. TestResult removeFromTestHistory: sel in: cls. ! ----- Method: TestCase class>>methodFailed: (in category 'testing') ----- methodFailed: aSelector ^ (self lastRun at: #failures) includes: aSelector! ----- Method: TestCase class>>methodPassed: (in category 'testing') ----- methodPassed: aSelector ^ (self lastRun at: #passed) includes: aSelector! ----- Method: TestCase class>>methodProgressed: (in category 'testing') ----- methodProgressed: aSelector ^ ((self storedMethodRaisedError: aSelector) or: [self storedMethodFailed: aSelector]) and: [self methodPassed: aSelector] ! ----- Method: TestCase class>>methodRaisedError: (in category 'testing') ----- methodRaisedError: aSelector ^ (self lastRun at: #errors) includes: aSelector! ----- Method: TestCase class>>methodRegressed: (in category 'testing') ----- methodRegressed: aSelector ^ (self storedMethodPassed: aSelector) and: [(self methodFailed: aSelector) or: [self methodRaisedError: aSelector]]! ----- Method: TestCase class>>newTestDictionary (in category 'history') ----- newTestDictionary ^ Dictionary new at: #timeStamp put: TimeStamp now; at: #passed put: Set new; at: #failures put: Set new; at: #errors put: Set new; yourself ! ----- Method: TestCase class>>resetHistory (in category 'history') ----- resetHistory history := nil! ----- Method: TestCase class>>resources (in category 'accessing') ----- resources ^#() ! ----- Method: TestCase class>>run: (in category 'instance creation') ----- run: aSymbol ^(self selector: aSymbol) run ! ----- Method: TestCase class>>selector: (in category 'instance creation') ----- selector: aSymbol ^self new setTestSelector: aSymbol ! ----- Method: TestCase class>>shouldGenerateLastStoredRunMethod (in category 'history') ----- shouldGenerateLastStoredRunMethod | sameRun | (self class methodDictionary includesKey: #lastStoredRun) ifFalse: [^ true]. sameRun := #(#passed #failures #errors) inject: true into: [ :ok :set | ok and: [(self lastRun at: set) = (self lastStoredRun at: set) ]]. ^ sameRun not ! ----- Method: TestCase class>>shouldInheritSelectors (in category 'testing') ----- shouldInheritSelectors "I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass. If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass." ^self superclass isAbstract or: [self testSelectors isEmpty] "$QA Ignore:Sends system method(superclass)$" ! ----- Method: TestCase class>>storedMethodFailed: (in category 'testing') ----- storedMethodFailed: aSelector ^ (self lastStoredRun at: #failures) includes: aSelector! ----- Method: TestCase class>>storedMethodPassed: (in category 'testing') ----- storedMethodPassed: aSelector ^ (self lastStoredRun at: #passed) includes: aSelector! ----- Method: TestCase class>>storedMethodRaisedError: (in category 'testing') ----- storedMethodRaisedError: aSelector ^ (self lastStoredRun at: #errors) includes: aSelector! ----- Method: TestCase class>>suite (in category 'instance creation') ----- suite ^self buildSuite ! ----- Method: TestCase class>>suiteClass (in category 'building suites') ----- suiteClass ^TestSuite ! ----- Method: TestCase class>>sunitVersion (in category 'accessing') ----- sunitVersion ^'3.1' ! ----- Method: TestCase class>>testSelectors (in category 'Accessing') ----- testSelectors ^(self selectors asArray select: [ :each | (each beginsWith: 'test') and: [ each numArgs isZero ] ]) sort! ----- Method: TestCase>>addDependentToHierachy: (in category 'dependencies') ----- addDependentToHierachy: anObject "an empty method. for Composite compability with TestSuite" ! ----- Method: TestCase>>assert: (in category 'accessing') ----- assert: aBooleanOrBlock aBooleanOrBlock value ifFalse: [self signalFailure: 'Assertion failed'] ! ----- Method: TestCase>>assert:description: (in category 'accessing') ----- assert: aBooleanOrBlock description: aStringOrBlock aBooleanOrBlock value ifFalse: [ | description | description := aStringOrBlock value. self logFailure: description. TestResult failure signal: description ] ! ----- Method: TestCase>>assert:description:resumable: (in category 'accessing') ----- assert: aBooleanOrBlock description: aString resumable: resumableBoolean | exception | aBooleanOrBlock value ifFalse: [self logFailure: aString. exception := resumableBoolean ifTrue: [TestResult resumableFailure] ifFalse: [TestResult failure]. exception signal: aString] ! ----- Method: TestCase>>assert:equals: (in category 'accessing') ----- assert: expected equals: actual ^self assert: expected = actual description: [ self comparingStringBetween: expected and: actual ] ! ----- Method: TestCase>>assert:equals:description: (in category 'accessing') ----- assert: expected equals: actual description: aString ^self assert: expected = actual description: [ aString , ': ', (self comparingStringBetween: expected and: actual) ]! ----- Method: TestCase>>assert:identical: (in category 'accessing') ----- assert: expected identical: actual ^self assert: expected == actual description: [ self comparingStringBetweenIdentical: expected and: actual ] ! ----- Method: TestCase>>assert:identical:description: (in category 'accessing') ----- assert: expected identical: actual description: aString ^self assert: expected == actual description: [ aString , ': ', (self comparingStringBetweenIdentical: expected and: actual) ]! ----- Method: TestCase>>comparingStringBetween:and: (in category 'private') ----- comparingStringBetween: expected and: actual ^ String streamContents: [:stream | stream nextPutAll: 'Expected '; nextPutAll: (expected printStringLimitedTo: 10); nextPutAll: ' but was '; nextPutAll: (actual printStringLimitedTo: 10); nextPutAll: '.' ]! ----- Method: TestCase>>comparingStringBetweenIdentical:and: (in category 'private') ----- comparingStringBetweenIdentical: expected and: actual ^ 'Expected {1} and actual {2} are not identical.' format: { expected printStringLimitedTo: 10. actual printStringLimitedTo: 10. }! ----- Method: TestCase>>debug (in category 'running') ----- debug self resources do: [ : res | res isAvailable ifFalse: [ ^ res signalInitializationError ] ]. [ self runCase ] ensure: [ self resources do: [ : each | each reset ] ]! ----- Method: TestCase>>debugAsFailure (in category 'running') ----- debugAsFailure | semaphore | semaphore := Semaphore new. self resources do: [:res | res isAvailable ifFalse: [^res signalInitializationError]]. [semaphore wait. self resources do: [:each | each reset]] fork. (self class selector: testSelector) runCaseAsFailure: semaphore.! ----- Method: TestCase>>defaultTimeout (in category 'accessing') ----- defaultTimeout "Answer the default timeout to use for tests in this test case. The timeout is a value in seconds." ^5 "seconds"! ----- Method: TestCase>>deny: (in category 'accessing') ----- deny: aBooleanOrBlock self assert: aBooleanOrBlock value not ! ----- Method: TestCase>>deny:description: (in category 'accessing') ----- deny: aBooleanOrBlock description: aString self assert: aBooleanOrBlock value not description: aString ! ----- Method: TestCase>>deny:description:resumable: (in category 'accessing') ----- deny: aBooleanOrBlock description: aString resumable: resumableBoolean self assert: aBooleanOrBlock value not description: aString resumable: resumableBoolean ! ----- Method: TestCase>>executeShould:inScopeOf: (in category 'private') ----- executeShould: aBlock inScopeOf: anExceptionalEvent ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: true] ! ----- Method: TestCase>>executeShould:inScopeOf:withDescriptionContaining: (in category 'private') ----- executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubString: aString) ] ! ----- Method: TestCase>>executeShould:inScopeOf:withDescriptionNotContaining: (in category 'private') ----- executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubString: aString) not ] ! ----- Method: TestCase>>executeShould:inScopeOf:withExceptionDo: (in category 'extensions') ----- executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock ^[aBlock value. false] on: anException do: [:exception | anotherBlock value: exception. exception return: true]! ----- Method: TestCase>>expectedFailures (in category 'testing') ----- expectedFailures ^ Array new! ----- Method: TestCase>>fail (in category 'extensions') ----- fail ^self assert: false! ----- Method: TestCase>>fail: (in category 'extensions') ----- fail: aString ^self assert: false description: aString.! ----- Method: TestCase>>failureLog (in category 'running') ----- failureLog ^Transcript ! ----- Method: TestCase>>isLogging (in category 'running') ----- isLogging "By default, we're not logging failures. If you override this in a subclass, make sure that you override #failureLog" ^false ! ----- Method: TestCase>>logFailure: (in category 'running') ----- logFailure: aString self isLogging ifTrue: [ self failureLog cr; nextPutAll: aString; flush] ! ----- Method: TestCase>>openDebuggerOnFailingTestMethod (in category 'running') ----- openDebuggerOnFailingTestMethod "SUnit has halted one step in front of the failing test method. Step over the 'self halt' and send into 'self perform: testSelector' to see the failure from the beginning" self halt; performTest! ----- Method: TestCase>>performTest (in category 'private') ----- performTest self perform: testSelector asSymbol ! ----- Method: TestCase>>printOn: (in category 'printing') ----- printOn: aStream testSelector ifNil: [super printOn: aStream] ifNotNil: [aStream nextPutAll: self class printString; nextPutAll: '>>#'; nextPutAll: testSelector] ! ----- Method: TestCase>>removeDependentFromHierachy: (in category 'dependencies') ----- removeDependentFromHierachy: anObject "an empty method. for Composite compability with TestSuite" ! ----- Method: TestCase>>resources (in category 'accessing') ----- resources | allResources resourceQueue | allResources := Set new. resourceQueue := OrderedCollection new. resourceQueue addAll: self class resources. [resourceQueue isEmpty] whileFalse: [ | next | next := resourceQueue removeFirst. allResources add: next. resourceQueue addAll: next resources]. ^allResources ! ----- Method: TestCase>>run (in category 'running') ----- run | result | result := TestResult new. self run: result. ^result ! ----- Method: TestCase>>run: (in category 'running') ----- run: aResult aResult runCase: self. ! ----- Method: TestCase>>runCase (in category 'running') ----- runCase "Run this TestCase. Time out if the test takes too long." [self timeout: [self setUp] after: self timeoutForSetUp. self timeout: [self performTest] after: self timeoutForTest] ensure: [self tearDown]! ----- Method: TestCase>>runCaseAsFailure: (in category 'running') ----- runCaseAsFailure: aSemaphore [self setUp. self openDebuggerOnFailingTestMethod] ensure: [ self tearDown. aSemaphore signal]! ----- Method: TestCase>>selector (in category 'accessing') ----- selector ^testSelector ! ----- Method: TestCase>>setTestSelector: (in category 'private') ----- setTestSelector: aSymbol testSelector := aSymbol ! ----- Method: TestCase>>setUp (in category 'running') ----- setUp! ----- Method: TestCase>>should: (in category 'accessing') ----- should: aBlock self assert: aBlock value ! ----- Method: TestCase>>should:description: (in category 'accessing') ----- should: aBlock description: aString self assert: aBlock value description: aString ! ----- Method: TestCase>>should:notTakeMoreThan: (in category 'extensions') ----- should: aBlock notTakeMoreThan: aDuration "Evaluate aBlock in a forked process and if it takes more than anInteger milliseconds to run we terminate the process and report a test failure. It'' important to use the active process for the test failure so that the failure reporting works correctly in the context of the exception handlers." | evaluated evaluationProcess result delay testProcess | evaluated := false. delay := Delay forDuration: aDuration. testProcess := Processor activeProcess. "Create a new process to evaluate aBlock" evaluationProcess := [ result := aBlock value. evaluated := true. delay unschedule. testProcess resume ] forkNamed: 'Process to evaluate should: notTakeMoreThanMilliseconds:'. "Wait the milliseconds they asked me to" delay wait. "After this point either aBlock was evaluated or not..." evaluated ifFalse: [ evaluationProcess terminate. self assert: false description: ('Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration)]. ^result! ----- Method: TestCase>>should:notTakeMoreThanMilliseconds: (in category 'extensions') ----- should: aBlock notTakeMoreThanMilliseconds: anInteger "For compatibility with other Smalltalks" self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! ----- Method: TestCase>>should:raise: (in category 'accessing') ----- should: aBlock raise: anExceptionalEvent ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) ! ----- Method: TestCase>>should:raise:description: (in category 'accessing') ----- should: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) description: aString ! ----- Method: TestCase>>should:raise:whoseDescriptionDoesNotInclude:description: (in category 'accessing') ----- should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) description: aString ! ----- Method: TestCase>>should:raise:whoseDescriptionIncludes:description: (in category 'accessing') ----- should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) description: aString ! ----- Method: TestCase>>should:raise:withExceptionDo: (in category 'extensions') ----- should: aBlock raise: anException withExceptionDo: anotherBlock ^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! ----- Method: TestCase>>shouldFix: (in category 'extensions') ----- shouldFix: aBlock ^self should: aBlock raise: Exception! ----- Method: TestCase>>shouldPass (in category 'testing') ----- shouldPass "Unless the selector is in the list we get from #expectedFailures, we expect it to pass" ^ (self expectedFailures includes: testSelector) not! ----- Method: TestCase>>shouldnt: (in category 'accessing') ----- shouldnt: aBlock self deny: aBlock value ! ----- Method: TestCase>>shouldnt:description: (in category 'accessing') ----- shouldnt: aBlock description: aString self deny: aBlock value description: aString ! ----- Method: TestCase>>shouldnt:raise: (in category 'accessing') ----- shouldnt: aBlock raise: anExceptionalEvent ^ [ aBlock value ] on: anExceptionalEvent do: [:e | self fail: 'Block raised ', e className, ': ', e messageText].! ----- Method: TestCase>>shouldnt:raise:description: (in category 'accessing') ----- shouldnt: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not description: aString ! ----- Method: TestCase>>shouldnt:raise:whoseDescriptionDoesNotInclude:description: (in category 'accessing') ----- shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) not description: aString ! ----- Method: TestCase>>shouldnt:raise:whoseDescriptionIncludes:description: (in category 'accessing') ----- shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) not description: aString ! ----- Method: TestCase>>signalFailure: (in category 'accessing') ----- signalFailure: aString TestResult failure signal: aString! ----- Method: TestCase>>tearDown (in category 'running') ----- tearDown! ----- Method: TestCase>>timeout: (in category 'accessing') ----- timeout: seconds "The timeout for a test should normally be set with a method annotation. However, for tests that are expected to run in images that do not support method annotations, the value may be set by setting the value from the #setUp method (i.e. prior to running the test method)." timeout := seconds! ----- Method: TestCase>>timeout:after: (in category 'running') ----- timeout: aBlock after: seconds "Evaluate the argument block. Time out if the evaluation is not complete after the given number of seconds. Handle the situation that a timeout may occur after a failure (during debug)" | theProcess delay watchdog | "the block will be executed in the current process" theProcess := Processor activeProcess. delay := Delay forSeconds: seconds. "make a watchdog process" watchdog := [ delay wait. "wait for timeout or completion" theProcess ifNotNil:[ theProcess signalException: (TestFailure new messageText: 'Test timed out') ] ] newProcess. "Watchdog needs to run at high priority to do its job (but not at timing priority)" watchdog priority: Processor timingPriority-1. "catch the timeout signal" watchdog resume. "start up the watchdog" ^[aBlock on: TestFailure, Error, Halt do:[:ex| theProcess := nil. ex pass. ]] ensure:[ "evaluate the receiver" theProcess := nil. "it has completed, so ..." delay delaySemaphore signal. "arrange for the watchdog to exit" ]! ----- Method: TestCase>>timeoutForSetUp (in category 'accessing') ----- timeoutForSetUp "Answer the timeout to use for setUp" | method | method := self class lookupSelector: testSelector asSymbol. (method pragmaAt: #timeout:) ifNotNil:[:tag| ^tag arguments first]. ^self defaultTimeout! ----- Method: TestCase>>timeoutForTest (in category 'accessing') ----- timeoutForTest "Answer the timeout to use for this test" | method | method := self class lookupSelector: testSelector asSymbol. (method pragmaAt: #timeout:) ifNotNil:[:tag| ^tag arguments first]. ^timeout ifNil: [self defaultTimeout]! Object subclass: #TestResource instanceVariableNames: 'name description' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! TestResource class instanceVariableNames: 'current'! TestResource class instanceVariableNames: 'current'! TestResource subclass: #SimpleTestResource instanceVariableNames: 'runningState hasRun hasSetup hasRanOnce' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests'! ----- Method: SimpleTestResource>>hasRun (in category 'testing') ----- hasRun ^hasRun ! ----- Method: SimpleTestResource>>hasSetup (in category 'testing') ----- hasSetup ^hasSetup ! ----- Method: SimpleTestResource>>isAvailable (in category 'testing') ----- isAvailable ^self runningState == self startedStateSymbol ! ----- Method: SimpleTestResource>>runningState (in category 'accessing') ----- runningState ^runningState ! ----- Method: SimpleTestResource>>runningState: (in category 'accessing') ----- runningState: aSymbol runningState := aSymbol ! ----- Method: SimpleTestResource>>setRun (in category 'running') ----- setRun hasRun := true ! ----- Method: SimpleTestResource>>setUp (in category 'running') ----- setUp self runningState: self startedStateSymbol. hasSetup := true ! ----- Method: SimpleTestResource>>startedStateSymbol (in category 'running') ----- startedStateSymbol ^#started ! ----- Method: SimpleTestResource>>stoppedStateSymbol (in category 'running') ----- stoppedStateSymbol ^#stopped ! ----- Method: SimpleTestResource>>tearDown (in category 'running') ----- tearDown self runningState: self stoppedStateSymbol ! ----- Method: TestResource class>>current (in category 'accessing') ----- current ^ current ifNil: [ current := self new] ! ----- Method: TestResource class>>current: (in category 'accessing') ----- current: aTestResource current := aTestResource ! ----- Method: TestResource class>>isAbstract (in category 'testing') ----- isAbstract "Override to true if a TestResource subclass is Abstract and should not have TestCase instances built from it" ^self name = #TestResource ! ----- Method: TestResource class>>isAvailable (in category 'testing') ----- isAvailable ^self current notNil and: [self current isAvailable] ! ----- Method: TestResource class>>isUnavailable (in category 'testing') ----- isUnavailable ^self isAvailable not ! ----- Method: TestResource class>>reset (in category 'Creation') ----- reset current ifNotNil: [:oldCurrent | current := nil. oldCurrent tearDown]! ----- Method: TestResource class>>resources (in category 'accessing') ----- resources ^#() ! ----- Method: TestResource class>>signalInitializationError (in category 'creation') ----- signalInitializationError ^TestResult signalErrorWith: 'Resource ' , self name , ' could not be initialized' ! ----- Method: TestResource>>description (in category 'accessing') ----- description ^description ifNil: [ '' ]! ----- Method: TestResource>>description: (in category 'accessing') ----- description: aString description := aString ! ----- Method: TestResource>>initialize (in category 'initializing') ----- initialize super initialize. self setUp ! ----- Method: TestResource>>isAvailable (in category 'testing') ----- isAvailable "override to provide information on the readiness of the resource" ^true ! ----- Method: TestResource>>isUnavailable (in category 'testing') ----- isUnavailable "override to provide information on the readiness of the resource" ^self isAvailable not ! ----- Method: TestResource>>name (in category 'accessing') ----- name ^name ifNil: [ self printString]! ----- Method: TestResource>>name: (in category 'accessing') ----- name: aString name := aString ! ----- Method: TestResource>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPutAll: self class printString ! ----- Method: TestResource>>resources (in category 'accessing') ----- resources ^self class resources ! ----- Method: TestResource>>setUp (in category 'running') ----- setUp "Does nothing. Subclasses should override this to initialize their resource" ! ----- Method: TestResource>>signalInitializationError (in category 'running') ----- signalInitializationError ^self class signalInitializationError ! ----- Method: TestResource>>tearDown (in category 'running') ----- tearDown "Does nothing. Subclasses should override this to tear down their resource" ! Object subclass: #TestResult instanceVariableNames: 'timeStamp failures errors passed' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! !TestResult commentStamp: '' prior: 0! This is a Collecting Parameter for the running of a bunch of tests. TestResult is an interesting object to subclass or substitute. #runCase: is the external protocol you need to reproduce. Kent has seen TestResults that recorded coverage information and that sent email when they were done.! ----- Method: TestResult class>>error (in category 'exceptions') ----- error ^self exError ! ----- Method: TestResult class>>exError (in category 'exceptions') ----- exError ^Error ! ----- Method: TestResult class>>failure (in category 'exceptions') ----- failure ^TestFailure ! ----- Method: TestResult class>>historyAt: (in category 'history') ----- historyAt: aTestCaseClass "I will return the last test dictionary for aTestCaseClass. If none found, I will create a new empty one and link it in the history." ^ aTestCaseClass history ! ----- Method: TestResult class>>historyAt:put: (in category 'history') ----- historyAt: aTestCaseClass put: aDictionary aTestCaseClass history: aDictionary "^ self history at: aTestCaseClass put: aDictionary "! ----- Method: TestResult class>>historyFor: (in category 'history') ----- historyFor: aTestCaseClass "I return the last test dictionary for aTestCaseClass. If none found, I return an empty dictionary but will not link it to the class in the history." | history | history := aTestCaseClass history. history ifNil: [ ^ self newTestDictionary ]. ^ history " ^ self history at: aTestCaseClass ifAbsent: [ self newTestDictionary ]"! ----- Method: TestResult class>>newTestDictionary (in category 'history') ----- newTestDictionary ^ Dictionary new at: #timeStamp put: TimeStamp now; at: #passed put: Set new; at: #failures put: Set new; at: #errors put: Set new; yourself ! ----- Method: TestResult class>>removeFromTestHistory:in: (in category 'history') ----- removeFromTestHistory: aSelector in: aTestCaseClass | lastRun | lastRun := self historyFor: aTestCaseClass. #(#passed #failures #errors) do: [ :set | (lastRun at: set) remove: aSelector ifAbsent: []]. ! ----- Method: TestResult class>>resumableFailure (in category 'exceptions') ----- resumableFailure ^ResumableTestFailure ! ----- Method: TestResult class>>signalErrorWith: (in category 'exceptions') ----- signalErrorWith: aString self error signal: aString ! ----- Method: TestResult class>>signalFailureWith: (in category 'exceptions') ----- signalFailureWith: aString self failure signal: aString ! ----- Method: TestResult class>>updateTestHistoryFor:status: (in category 'history') ----- updateTestHistoryFor: aTestCase status: aSymbol | cls sel | cls := aTestCase class. sel := aTestCase selector. self removeFromTestHistory: sel in: cls. ((self historyAt: cls) at: aSymbol ) add: sel! ----- Method: TestResult>>classesTested (in category 'accessing') ----- classesTested ^ (self tests collect: [ :testCase | testCase class ]) asSet! ----- Method: TestResult>>correctCount (in category 'accessing') ----- correctCount "depreciated - use #passedCount" ^self passedCount ! ----- Method: TestResult>>defects (in category 'accessing') ----- defects ^OrderedCollection new addAll: self errors; addAll: self failures; yourself ! ----- Method: TestResult>>diff: (in category 'diff') ----- diff: aTestResult "Return a collection that contains differences" | passed1Selectors failed1Selectors errors1Selectors passed2Selectors failed2Selectors errors2Selectors | passed1Selectors := self passed collect: [:testCase | testCase selector]. failed1Selectors := self failures collect: [:testCase | testCase selector]. errors1Selectors := self errors collect: [:testCase | testCase selector]. passed2Selectors := aTestResult passed collect: [:testCase | testCase selector]. failed2Selectors := aTestResult failures collect: [:testCase | testCase selector]. errors2Selectors := aTestResult errors collect: [:testCase | testCase selector]. ^ {passed1Selectors copyWithoutAll: passed2Selectors . failed1Selectors copyWithoutAll: failed2Selectors . errors1Selectors copyWithoutAll: errors2Selectors}! ----- Method: TestResult>>dispatchResultsIntoHistory (in category 'history') ----- dispatchResultsIntoHistory self classesTested do: [ :testClass | self class historyAt: testClass put: (self selectResultsForTestCase: testClass) ]. ! ----- Method: TestResult>>errorCount (in category 'accessing') ----- errorCount ^self errors size ! ----- Method: TestResult>>errors (in category 'compatibility') ----- errors ^ self unexpectedErrors! ----- Method: TestResult>>expectedDefectCount (in category 'accessing') ----- expectedDefectCount ^ self expectedDefects size! ----- Method: TestResult>>expectedDefects (in category 'accessing') ----- expectedDefects ^ (errors, failures asOrderedCollection) select: [:each | each shouldPass not] ! ----- Method: TestResult>>expectedPassCount (in category 'accessing') ----- expectedPassCount ^ self expectedPasses size! ----- Method: TestResult>>expectedPasses (in category 'accessing') ----- expectedPasses ^ passed select: [:each | each shouldPass] ! ----- Method: TestResult>>failureCount (in category 'accessing') ----- failureCount ^self failures size ! ----- Method: TestResult>>failures (in category 'compatibility') ----- failures ^ self unexpectedFailures, self unexpectedPasses ! ----- Method: TestResult>>hasErrors (in category 'testing') ----- hasErrors ^self errors size > 0 ! ----- Method: TestResult>>hasFailures (in category 'testing') ----- hasFailures ^self failures size > 0 ! ----- Method: TestResult>>hasPassed (in category 'testing') ----- hasPassed ^ self hasErrors not and: [ self hasFailures not ]! ----- Method: TestResult>>initialize (in category 'initialization') ----- initialize super initialize. passed := OrderedCollection new. failures := Set new. errors := OrderedCollection new. timeStamp := TimeStamp now! ----- Method: TestResult>>isError: (in category 'testing') ----- isError: aTestCase ^self errors includes: aTestCase ! ----- Method: TestResult>>isErrorFor:selector: (in category 'querying') ----- isErrorFor: class selector: selector ^ self errors anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ----- Method: TestResult>>isFailure: (in category 'testing') ----- isFailure: aTestCase ^self failures includes: aTestCase ! ----- Method: TestResult>>isFailureFor:selector: (in category 'querying') ----- isFailureFor: class selector: selector ^ self failures anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ----- Method: TestResult>>isPassed: (in category 'testing') ----- isPassed: aTestCase ^self passed includes: aTestCase ! ----- Method: TestResult>>isPassedFor:selector: (in category 'querying') ----- isPassedFor: class selector: selector ^ self passed anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ----- Method: TestResult>>passed (in category 'compatibility') ----- passed ^ self expectedPasses, self expectedDefects! ----- Method: TestResult>>passedCount (in category 'accessing') ----- passedCount ^self passed size ! ----- Method: TestResult>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPutAll: self runCount printString; nextPutAll: ' run, '; nextPutAll: self expectedPassCount printString; nextPutAll: ' passes, '; nextPutAll: self expectedDefectCount printString; nextPutAll:' expected failures, '; nextPutAll: self unexpectedFailureCount printString; nextPutAll: ' failures, '; nextPutAll: self unexpectedErrorCount printString; nextPutAll:' errors, '; nextPutAll: self unexpectedPassCount printString; nextPutAll:' unexpected passes'.! ----- Method: TestResult>>runCase: (in category 'running') ----- runCase: aTestCase | testCasePassed | testCasePassed := true. [[aTestCase runCase] on: self class failure do: [:signal | failures add: aTestCase. testCasePassed := false. signal return: false]] on: self class error do: [:signal | errors add: aTestCase. testCasePassed := false. signal return: false]. testCasePassed ifTrue: [passed add: aTestCase]! ----- Method: TestResult>>runCount (in category 'accessing') ----- runCount ^ passed size + failures size + errors size! ----- Method: TestResult>>selectResultsForTestCase: (in category 'history') ----- selectResultsForTestCase: aTestCaseClass | passedSelectors errorsSelectors failuresSelectors | passedSelectors := self passed select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. errorsSelectors := self errors select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. failuresSelectors := self failures select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. ^ self class newTestDictionary at: #passed put: passedSelectors asSet; at: #failures put: failuresSelectors asSet; at: #errors put: errorsSelectors asSet; yourself ! ----- Method: TestResult>>tests (in category 'accessing') ----- tests ^(OrderedCollection new: self runCount) addAll: passed; addAll: failures; addAll: errors; yourself! ----- Method: TestResult>>timeStamp (in category 'accessing') ----- timeStamp ^ timeStamp! ----- Method: TestResult>>timeStamp: (in category 'accessing') ----- timeStamp: anObject timeStamp := anObject! ----- Method: TestResult>>unexpectedErrorCount (in category 'accessing') ----- unexpectedErrorCount ^ self unexpectedErrors size! ----- Method: TestResult>>unexpectedErrors (in category 'accessing') ----- unexpectedErrors ^ errors select: [:each | each shouldPass] ! ----- Method: TestResult>>unexpectedFailureCount (in category 'accessing') ----- unexpectedFailureCount ^ self unexpectedFailures size! ----- Method: TestResult>>unexpectedFailures (in category 'accessing') ----- unexpectedFailures ^ failures select: [:each | each shouldPass] ! ----- Method: TestResult>>unexpectedPassCount (in category 'accessing') ----- unexpectedPassCount ^ self unexpectedPasses size! ----- Method: TestResult>>unexpectedPasses (in category 'accessing') ----- unexpectedPasses ^ passed select: [:each | each shouldPass not] ! ----- Method: TestResult>>updateResultsInHistory (in category 'history') ----- updateResultsInHistory #(#passed #failures #errors) do: [ :status | (self perform: status) do: [ :testCase | self class updateTestHistoryFor: testCase status: status ] ]! Object subclass: #TestSuite instanceVariableNames: 'tests resources name' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Kernel'! !TestSuite commentStamp: '' prior: 0! This is a Composite of Tests, either TestCases or other TestSuites. The common protocol is #run: aTestResult and the dependencies protocol! ----- Method: TestSuite class>>named: (in category 'instance creation') ----- named: aString ^self new name: aString; yourself ! ----- Method: TestSuite>>addDependentToHierachy: (in category 'dependencies') ----- addDependentToHierachy: anObject self addDependent: anObject. self tests do: [ :each | each addDependentToHierachy: anObject] ! ----- Method: TestSuite>>addTest: (in category 'accessing') ----- addTest: aTest self tests add: aTest ! ----- Method: TestSuite>>addTests: (in category 'accessing') ----- addTests: aCollection aCollection do: [:eachTest | self addTest: eachTest] ! ----- Method: TestSuite>>debug (in category 'running') ----- debug self tests do: [ : each | self changed: each. each debug ]! ----- Method: TestSuite>>defaultResources (in category 'accessing') ----- defaultResources ^self tests inject: Set new into: [:coll :testCase | coll addAll: testCase resources; yourself] ! ----- Method: TestSuite>>name (in category 'accessing') ----- name ^name ! ----- Method: TestSuite>>name: (in category 'accessing') ----- name: aString name := aString ! ----- Method: TestSuite>>removeDependentFromHierachy: (in category 'dependencies') ----- removeDependentFromHierachy: anObject self removeDependent: anObject. self tests do: [ :each | each removeDependentFromHierachy: anObject] ! ----- Method: TestSuite>>resources (in category 'accessing') ----- resources ^ resources ifNil: [resources := self defaultResources] ! ----- Method: TestSuite>>resources: (in category 'accessing') ----- resources: anObject resources := anObject ! ----- Method: TestSuite>>resultClass (in category 'private') ----- resultClass ^ TestResult.! ----- Method: TestSuite>>run (in category 'running') ----- run | result | result := self resultClass new. self resources do: [ :res | res isAvailable ifFalse: [^res signalInitializationError]]. [self run: result] ensure: [self resources do: [:each | each reset]]. ^result ! ----- Method: TestSuite>>run: (in category 'running') ----- run: aResult self tests do: [:each | self changed: each. each run: aResult]. ! ----- Method: TestSuite>>tests (in category 'accessing') ----- tests ^ tests ifNil: [tests := OrderedCollection new] ! From commits at source.squeak.org Fri Jun 5 20:15:34 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:15:38 2015 Subject: [squeak-dev] Squeak 4.6: ST80Tests-nice.2.mcz Message-ID: Chris Muller uploaded a new version of ST80Tests to project Squeak 4.6: http://source.squeak.org/squeak46/ST80Tests-nice.2.mcz ==================== Summary ==================== Name: ST80Tests-nice.2 Author: nice Time: 16 December 2013, 5:30:14.254 pm UUID: 7ee5426b-73f1-48ac-8ec4-3943dc452cb6 Ancestors: ST80Tests-fbs.1 MVCToolBuilderTests are kind of TestCase and belong to ST80Tests ==================== Snapshot ==================== SystemOrganization addCategory: #ST80Tests! ToolBuilderTests subclass: #MVCToolBuilderTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ST80Tests'! !MVCToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! Tests for the MVC tool builder.! ----- Method: MVCToolBuilderTests>>acceptWidgetText (in category 'support') ----- acceptWidgetText widget hasUnacceptedEdits: true. widget controller accept.! ----- Method: MVCToolBuilderTests>>changeListWidget (in category 'support') ----- changeListWidget widget changeModelSelection: widget getCurrentSelectionIndex + 1.! ----- Method: MVCToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- expectedButtonSideEffects ^#(getState)! ----- Method: MVCToolBuilderTests>>fireButtonWidget (in category 'support') ----- fireButtonWidget widget performAction.! ----- Method: MVCToolBuilderTests>>setUp (in category 'support') ----- setUp super setUp. builder := MVCToolBuilder new.! ----- Method: MVCToolBuilderTests>>tearDown (in category 'support') ----- tearDown ScreenController new restoreDisplay. super tearDown! ----- Method: MVCToolBuilderTests>>testAddAction (in category 'tests-not applicable') ----- testAddAction "MVCToolBuilder does not implement #buildPluggableMenu:"! ----- Method: MVCToolBuilderTests>>testAddTargetSelectorArgumentList (in category 'tests-not applicable') ----- testAddTargetSelectorArgumentList "MVCToolBuilder does not implement #buildPluggableMenu:"! ----- Method: MVCToolBuilderTests>>testButtonFiresBlock (in category 'tests-not applicable') ----- testButtonFiresBlock "MVC buttons only support action Symbols"! ----- Method: MVCToolBuilderTests>>testButtonFiresMessage (in category 'tests-not applicable') ----- testButtonFiresMessage "MVC buttons only support action Symbols, not MessageSends"! ----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabled (in category 'tests-not applicable') ----- testButtonInitiallyDisabled "MVC does not have button enablement"! ----- Method: MVCToolBuilderTests>>testButtonInitiallyDisabledSelector (in category 'tests-not applicable') ----- testButtonInitiallyDisabledSelector "MVC does not have button enablement"! ----- Method: MVCToolBuilderTests>>testGetButtonColor (in category 'tests-not applicable') ----- testGetButtonColor "MVC buttons do not have color"! ----- Method: MVCToolBuilderTests>>testGetButtonEnabled (in category 'tests-not applicable') ----- testGetButtonEnabled "MVC does not have button enablement"! ----- Method: MVCToolBuilderTests>>testGetInputFieldColor (in category 'tests-not applicable') ----- testGetInputFieldColor "MVC input fields do not have color"! ----- Method: MVCToolBuilderTests>>testGetPanelChildren (in category 'tests-not applicable') ----- testGetPanelChildren "MVC panels do not allow changing children"! ----- Method: MVCToolBuilderTests>>testGetTextColor (in category 'tests-not applicable') ----- testGetTextColor "not supported in MVC"! ----- Method: MVCToolBuilderTests>>testGetWindowChildren (in category 'tests-not applicable') ----- testGetWindowChildren "not supported in MVC"! ----- Method: MVCToolBuilderTests>>testGetWindowLabel (in category 'tests-not applicable') ----- testGetWindowLabel "not supported in MVC"! ----- Method: MVCToolBuilderTests>>testTreeExpandPath (in category 'tests-not applicable') ----- testTreeExpandPath "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testTreeExpandPathFirst (in category 'tests-not applicable') ----- testTreeExpandPathFirst "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testTreeGetSelectionPath (in category 'tests-not applicable') ----- testTreeGetSelectionPath "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testTreeRoots (in category 'tests-not applicable') ----- testTreeRoots "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testTreeWidgetID (in category 'tests-not applicable') ----- testTreeWidgetID "MVCToollBuilder does not implement trees"! ----- Method: MVCToolBuilderTests>>testWindowCloseAction (in category 'tests-not applicable') ----- testWindowCloseAction "This can only work if we're actually run in MVC" World isNil ifTrue: [super testWindowCloseAction]! TestCase subclass: #ST80PackageDependencyTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ST80Tests'! ----- Method: ST80PackageDependencyTest>>testPackage:dependsExactlyOn: (in category 'as yet unclassified') ----- testPackage: pkgName dependsExactlyOn: pkgList "Ensure that the package with the given name depends only on the packages in pkgList. NOTE: If you use this for fixing dependencies, classDeps includes the classes and users from the package(s) not declared as dependents. Basically, you need to fix all the references in classDeps to make the test pass." | classDeps pi pkgDeps | classDeps := IdentityDictionary new. pi := PackageOrganizer default packageNamed: pkgName ifAbsent:[^self]. "unloaded" pi classes do:[:pkgClass| (classDeps at: (pkgClass superclass ifNil:[ProtoObject]) ifAbsentPut:[OrderedCollection new]) add: pkgClass name, ' superclass'. ]. pi methods do:[:mref| | cm | cm := mref compiledMethod. 1 to: cm numLiterals do:[:i| | lit | ((lit := cm literalAt: i) isVariableBinding and:[lit value isBehavior]) ifTrue:[(classDeps at: lit value ifAbsentPut:[OrderedCollection new]) add: cm methodClass asString, '>>', cm selector]]]. pkgDeps := Dictionary new. classDeps keys do:[:aClass| | pkg | pkg := PackageOrganizer default packageOfClass: aClass ifNone:[nil]. pkg ifNil:[ Transcript cr; show: 'WARNING: No package for ', aClass. (classDeps removeKey: aClass) do:[:each| Transcript crtab; show: each]. ] ifNotNil:[ (pkgDeps at: pkg name ifAbsentPut:[OrderedCollection new]) add: aClass. ]. ]. (pkgDeps removeKey: pkgName ifAbsent:[#()]) do:[:aClass| classDeps removeKey: aClass ifAbsent:[]]. pkgList do:[:pkg| self assert: (pkgDeps includesKey: pkg) description: pkgName, ' no longer depends on ', pkg. (pkgDeps removeKey: pkg ifAbsent: [#()]) do:[:aClass| classDeps removeKey: aClass ifAbsent:[]]. ]. classDeps keysAndValuesDo:[:class :deps| Transcript cr; show: class name, ' dependencies:'. deps do:[:each| Transcript crtab; show: each]. ]. self assert: pkgDeps isEmpty description: pkgName, ' now depends on ', pkgDeps. ! ----- Method: ST80PackageDependencyTest>>testST80 (in category 'as yet unclassified') ----- testST80 self testPackage: 'ST80' dependsExactlyOn: #( Collections Compiler Files Graphics Kernel Morphic Multilingual Network SUnit System 'ToolBuilder-Kernel' Tools ).! From commits at source.squeak.org Fri Jun 5 20:15:42 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:15:43 2015 Subject: [squeak-dev] Squeak 4.6: WebClient-Help-ar.10.mcz Message-ID: Chris Muller uploaded a new version of WebClient-Help to project Squeak 4.6: http://source.squeak.org/squeak46/WebClient-Help-ar.10.mcz ==================== Summary ==================== Name: WebClient-Help-ar.10 Author: ar Time: 31 August 2010, 11:09:04.966 pm UUID: 4c7a5c81-01c4-fc4d-a98e-1271bbd0c47d Ancestors: WebClient-Help-ar.9 Update change log for WebClient and WebServer 1.4. ==================== Snapshot ==================== SystemOrganization addCategory: #'WebClient-Help'! CustomHelp subclass: #WebClientHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'WebClient-Help'! ----- Method: WebClientHelp class>>authentication (in category 'pages') ----- authentication "This method was automatically generated. Edit it using:" "WebClientHelp edit: #authentication" ^HelpTopic title: 'Authentication' contents: 'WebClient supports basic and digest authentication by default. WebClient delegates the retrieval of username/password to WebUtils which prompts the user for credentials. WebClient can either be supplied with specific credentials to be used or custom credentials handlers, for example: | client | client := WebClient new. client username: ''squeak''. client password: ''squeak''. client httpGet: ''http://www.squeak.org/protected''. Proxy authentication works the same way as authentication but operates on a different authentication context to allow different sets of credentials to work. !! ]style[(288 1 1 1 6 1 1 2 6 1 2 11 3 3 6 1 9 1 8 3 6 1 9 1 8 3 6 1 8 1 33 2 158),cblack;,cgray;,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,!!' readStream nextChunkText! ----- Method: WebClientHelp class>>bookName (in category 'accessing') ----- bookName "Returns the name of the custom help book" ^'WebClient'! ----- Method: WebClientHelp class>>changeLog (in category 'pages') ----- changeLog "This method was automatically generated. Edit it using:" "WebClientHelp edit: #changeLog" ^HelpTopic title: 'Version History' contents: 'WebClient 1.4: * Fixes cookie handling to be in line with RFC 2109 * Provide the final redirect url in requests * OAuth support via WebUtils. * Support for POST using chunked transfer-encoding WebClient 1.3: * Added logging in common log format * Added support for SSL/TLS via SqueakSSL. WebClient 1.2: * Added support for multipart/form-data posts * Added WebSocket support WebClient 1.1: * Added support for HEAD, TRACE, OPTIONS, and PUT methods WebClient 1.0: * Initial release. !!' readStream nextChunkText! ----- Method: WebClientHelp class>>cookieSupport (in category 'pages') ----- cookieSupport "This method was automatically generated. Edit it using:" "WebClientHelp edit: #cookieSupport" ^HelpTopic title: 'Cookie Support' contents: 'WebClient supports session cookies. Cookies are preserved within one WebClient session but not across multiple session (cookies can be copied or shared between WebClients which makes it easy to support where needed). Support for cookies can be disabled via WebClient''s #acceptCookies: property. !!' readStream nextChunkText! ----- Method: WebClientHelp class>>introduction (in category 'pages') ----- introduction "This method was automatically generated. Edit it using:" "WebClientHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'WebClient is a simple, yet reasonably complete HTTP client. WebClient uses HTTP 1.1, supports proxies (both authenticating and not), redirect support and authentication. WebClient comes with WebServer, an HTTP server implementation with a similarly simple yet reasonably complete approach.!!' readStream nextChunkText! ----- Method: WebClientHelp class>>multipleRequests (in category 'pages') ----- multipleRequests "This method was automatically generated. Edit it using:" "WebClientHelp edit: #multipleRequests" ^HelpTopic title: 'Multiple Requests' contents: 'WebClient can and should be used for multiple requests to the same host. This will ensure persistent connections as well as having cookies processed properly within one session: | client resp | client := WebClient new. resp := client httpGet: ''http://www.squeak.org/''. resp := client httpGet: ''http://www.squeak.org/Download''. resp := client httpGet: ''http://www.squeak.org/Features''. client close. One important issue to keep in mind is that because WebClient is optimized for persistent connections, you need to close it when you are done. That is not true for WebClient''s class-side convenience APIs, which prefetch the response and close the socket. Generally speaking, whenever you say ''WebClient new'' you need to close the client when you''re done (however, you can do so by sending #close to a response you''ve received). For example: "Convenience API. Don''t need to close, but prefetches result." WebClient httpGet: ''http://www.squeak.org''. | client resp | "Regular use. Create WebClient, return after header is read ..." client := WebClient new. [response := client httpGet: ''http://www.squeak.org/''. "... then fetch (or stream) the content ..." response content. ] ensure:[ "... and close the client when done." client close. ].!! ]style[(179 1 1 1 6 1 4 1 1 2 6 1 2 11 3 3 4 1 2 1 6 1 8 1 24 3 4 1 2 1 6 1 8 1 32 3 4 1 2 1 6 1 8 1 32 3 6 1 5 2 443 1 62 12 8 1 23 4 1 1 6 1 4 1 1 2 64 1 1 6 1 2 11 3 4 8 1 2 1 6 1 8 1 24 3 44 2 8 1 7 5 7 4 37 3 6 1 5 5),cblack;,cgray;,cblack;,c107107107,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,,cblack;,c000127127,cblack;,c000000127,cblack;,c127000127,cblack;,cgray;,cblack;,c107107107,cblack;,c107107107,cblack;,cgray;,cblack;,c000127127,,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,cblack;,c000127127,cblack;,c107107107,cblack;,c000000127,cblack;!!' readStream nextChunkText! ----- Method: WebClientHelp class>>pages (in category 'accessing') ----- pages "Returns a collection of method selectors to return the pages of the custom help book" ^#(introduction webClientRequests webClientResponses multipleRequests authentication redirectSupport proxySupport cookieSupport changeLog)! ----- Method: WebClientHelp class>>proxySupport (in category 'pages') ----- proxySupport "This method was automatically generated. Edit it using:" "WebClientHelp edit: #proxySupport" ^HelpTopic title: 'Proxy Support' contents: 'WebClient supports connecting via http proxies, including authenticating proxies. WebClient delegates proxy detection to its ProxyHandler which is responsible for performing the proper actions. Proxy authentication is handled in a similar way as regular authentication. The defaults are implemented in WebUtils. !!' readStream nextChunkText! ----- Method: WebClientHelp class>>redirectSupport (in category 'pages') ----- redirectSupport "This method was automatically generated. Edit it using:" "WebClientHelp edit: #redirectSupport" ^HelpTopic title: 'Redirect Handling' contents: 'WebClient handles http redirect requests (3xx) transparently. WebClient detects infinite redirect loops and gives up after a certain number of attempts, returning the redirect (3xx) response which caused it to give up. Users of WebClient will only see 3xx responses if WebClient has given up (i.e., returning a 3xx should be considered an error). Redirect handling can be disabled by setting #allowRedirect property to the desired value. When disabled, WebClient will not attempt to perform any redirect handling.!!' readStream nextChunkText! ----- Method: WebClientHelp class>>webClientRequests (in category 'pages') ----- webClientRequests "This method was automatically generated. Edit it using:" "WebClientHelp edit: #webClientRequests" ^HelpTopic title: 'Using WebClient' contents: 'The simplest form to use WebClient is by one of its convenience APIs: WebClient httpGet: ''http://www.squeak.org/''. WebClient httpPost: ''http://www.squeak.org/'' content:''Hello Squeak'' type: ''text/plain''. For more elaborate use of headers and some other options in the request, a client can utilize modified variants: WebClient new httpGet: ''http://www.squeak.org/'' do:[:req| "Set an if-modified-since header" req headerAt: ''If-Modified-Since'' put: ''Sat, 29 Oct 1994 19:43:31 GMT''. "Add several accept headers" req addHeader: ''Accept'' value: ''text/plain''. req addHeader: ''Accept'' value: ''application/x-foo-bar''. req addHeader: ''Accept'' value: ''image/jpg''. ]. The set of utility methods is limited to a few useful ones but it is easy to do the setup on your own: | url client request data | data := ''Hello Squeak''. "POST data" url := ''http://www.squeak.org/''. "POST url" client := WebClient new initializeFromUrl: url. "sets host etc" request := client requestWithUrl: url. "sets path etc" request method: ''POST''. "sets method" request headerAt: ''Content-Length'' put: data size. request headerAt: ''Content-Type'' put: ''text/plain''. "... any other headers required ..." ^client sendRequest: request content: data readStream size: data size. The utility methods like httpGet: etc. are similarly simple requests. !! ]style[(71 11 8 1 24 13 9 1 24 1 8 14 1 5 1 12 2 115 11 3 1 8 1 24 1 3 2 3 1 3 33 3 3 1 9 1 19 1 4 1 31 4 28 3 3 1 10 1 8 1 6 1 12 4 3 1 10 1 8 1 6 1 23 4 3 1 10 1 8 1 6 1 11 6 105 1 1 1 3 1 6 1 7 1 4 1 1 2 4 1 2 1 14 9 11 2 3 1 2 1 24 7 10 2 6 1 2 11 3 1 18 1 3 4 15 2 7 1 2 1 6 1 15 1 3 6 15 2 7 1 7 1 6 8 13 2 7 1 9 1 16 1 4 1 4 1 4 3 7 1 9 1 14 1 4 1 12 3 36 2 1 6 1 12 1 7 4 8 1 4 1 10 3 5 1 4 1 4 2 71),cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,cgray;,cblack;,c107107107,cblack;,c107107107,cblack;,c107107107,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c127000127,cblack;,c000127127,cblack;,c107107107,cblack;,b,cblack;,c127000127,cblack;,c000127127,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c000000127,cblack;,c107107107,cblack;,c000127127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000127127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c127000000,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,!!' readStream nextChunkText! ----- Method: WebClientHelp class>>webClientResponses (in category 'pages') ----- webClientResponses "This method was automatically generated. Edit it using:" "WebClientHelp edit: #webClientResponses" ^HelpTopic title: 'Responses' contents: 'The WebClient request methods return a WebResponse that the client can process: | resp | resp := WebClient httpGet: ''http://www.squeak.org/''. resp isSuccess ifFalse:[^self error: resp status]. "Process the content from the response" ^resp content In addition, content can be streamed from the response so that it does not need to be downloaded all at once: | client resp file | client := WebClient new. [resp := client httpGet: ''http://www.squeak.org/''. resp isSuccess ifFalse:[^self error: resp status]. "Stream the content from the response" file := FileStream newFileNamed: ''page.html''. resp streamTo: file size: resp contentLength progress:[:total :amount]. file close] ensure:[client close]. The progress block in the above can be omitted but has been included in this example to illustrate its usage. The block takes a total length (which can be nil if the length is not known) and the amount that has been loaded. !! ]style[(81 1 1 1 4 1 1 2 4 1 2 11 8 1 24 3 4 1 9 1 8 1 5 1 6 1 4 1 6 4 39 2 1 4 1 7 1 112 1 1 1 6 1 4 1 4 1 1 2 6 1 2 11 3 4 4 1 2 1 6 1 8 1 24 3 4 1 9 1 8 1 5 1 6 1 4 1 6 1 3 38 2 4 1 2 12 13 1 11 3 4 1 9 1 4 5 5 1 4 1 13 4 9 1 1 5 2 6 1 3 4 1 5 2 7 1 6 1 5 3 225),cblack;,cgray;,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,cblack;,c127000000,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000127127,cblack;,c127000000,c107107107,cblack;,c000000127,cblack;,,cblack;,cgray;,cblack;,c107107107,cblack;,c107107107,cblack;,c107107107,cblack;,cgray;,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c107107107,cblack;,b,cblack;,c107107107,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,c000127000,c127000000,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,c000127000,cblack;,c000127127,cblack;,c107107107,cblack;,b,cblack;,c000000127,cblack;,c127000127,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,c107107107,cblack;,c000000127,cblack;,c000000127,cblack;,c107107107,cblack;,c000000127,cblack;,!!' readStream nextChunkText! WebClientHelp subclass: #WebClientReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'WebClient-Help'! ----- Method: WebClientReference class>>bookName (in category 'accessing') ----- bookName ^'Reference'! ----- Method: WebClientReference class>>builder (in category 'accessing') ----- builder ^PackageAPIHelpBuilder! ----- Method: WebClientReference class>>packages (in category 'accessing') ----- packages ^#('WebClient-Core')! CustomHelp subclass: #WebServerHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'WebClient-Help'! ----- Method: WebServerHelp class>>addingActions (in category 'pages') ----- addingActions "This method was automatically generated. Edit it using:" "WebServerHelp edit: #addingActions" ^HelpTopic title: 'Adding Actions' contents: 'Let''s add some real stuff that might be useful on a server: WebServer default addService: ''/smalltalk'' action:[:req| | action | action := (req fields at: ''get'' ifAbsent:['''']) asSymbol. req send200Response: (Smalltalk perform: action) asString ]. We can now request some interesting things like: (WebClient httpGet:''http://localhost:8080/smalltalk?get=systemInformationString'') content. (WebClient httpGet:''http://localhost:8080/smalltalk?get=platformName'') content. Obviously, this poses quite a risk for abuse. One way to limit this risk is to expose specific actions, such as here: #(systemInformationString platformName) do:[:symbol| WebServer default addService: ''/info/'', symbol action:[:req| req send200Response: (Smalltalk perform: symbol) asString]]. (WebClient httpGet:''http://localhost:8080/info/systemInformationString'') content. (WebClient httpGet:''http://localhost:8080/info/platformName'') content. Alternatively, authentication can be used to limit access to exposed resources. !! ]style[(61 11 7 1 11 1 12 1 7 2 3 1 1 1 1 6 1 1 3 6 1 2 1 1 3 1 6 1 3 1 5 1 9 4 1 1 8 4 3 1 16 1 1 10 8 1 6 1 1 8 5 51 12 8 61 2 7 14 8 50 2 7 2 121 3 23 1 12 2 3 2 6 1 13 7 1 11 1 8 1 1 6 1 7 1 1 3 1 4 3 1 16 1 1 10 8 1 6 1 1 8 1 3 1 12 8 52 2 7 14 8 41 2 7 2 82),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,b,cblack;,c000127000,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000127,c000127000,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000127000,cblack;,c000000127,cblack;,cgray;,c000127000,cblack;,c000000127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,c000127000,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>addingServices (in category 'pages') ----- addingServices "This method was automatically generated. Edit it using:" "WebServerHelp edit: #addingServices" ^HelpTopic title: 'Adding Services' contents: 'Once the server is running, you can point your browser to http://localhost:8080 but since we haven''t told WebServer what we''d like to do all we get is a 404 (not found) response. To tell WebServer what to do we need to register a service: WebServer default addService: ''/hello'' action:[:req| req send200Response: ''Hello World''. ]. The service takes a path (/hello) and an action to perform for any request that maps to this path. We can now fetch the response in a browser by going to http://localhost:8080/hello or directly using WebClient: (WebClient httpGet:''http://localhost:8080/hello'') content. (WebClient httpGet:''http://localhost:8080/hello/squeak'') content. !! ]style[(240 11 7 1 11 1 8 1 7 2 3 1 3 3 1 16 1 13 6 213 12 8 29 2 7 14 8 36 2 7 2),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;!!' readStream nextChunkText! ----- Method: WebServerHelp class>>authentication (in category 'pages') ----- authentication "This method was automatically generated. Edit it using:" "WebServerHelp edit: #authentication" ^HelpTopic title: 'Authentication' contents: 'To add authentication you can use web server as follows: WebServer default addService: ''/smalltalk'' action:[:req| | action | WebServer default authenticate: req realm: ''squeak'' methods: #(digest basic) do:[ action := (req fields at: ''get'' ifAbsent:['''']) asSymbol. req send200Response: (Smalltalk perform: action) asString. ]. ]. The above supports both digest as well as basic authentication for accessing the /smalltalk service. Let''s add a user so that we can access it: WebServer default passwordAt: ''squeak'' realm: ''squeak'' put: ''squeak''. The server does NOT store plain text passwords, but rather hashes. To be precise, it stores the ha1 term used in digest authentication which is the same hash produced by htdigest. We can now access the /smalltalk service by providing user name ''squeak'' and password ''squeak''. (WebClient httpGet:''http://localhost:8080/smalltalk?get=platformName'') content. Unfortunately, digest authentication can be slow since our MD5 implementation is rather pathetic. !! ]style[(58 11 7 1 11 1 12 1 7 2 3 1 1 1 1 6 1 1 13 7 1 13 1 3 1 6 1 8 1 8 3 6 1 5 2 3 1 4 6 1 2 1 1 3 1 6 1 3 1 5 1 9 1 2 1 1 1 8 5 3 1 16 1 1 10 8 1 6 1 1 8 4 1 6 146 11 7 1 11 1 8 1 6 1 8 1 4 1 8 2 278 12 8 50 2 7 2 100),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,cgray;,cblack;,b,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000000,c127000127,c127000000,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,cgray;,c127000127,cblack;,c000000127,cblack;,c000127000,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>bookName (in category 'accessing') ----- bookName "Returns the name of the custom help book" ^'WebServer'! ----- Method: WebServerHelp class>>changeLog (in category 'pages') ----- changeLog "This method was automatically generated. Edit it using:" "WebServerHelp edit: #changeLog" ^HelpTopic title: 'Versions' contents: 'WebServer 1.4: * Fixes cookie handling to be in line with RFC 2109 * Support for responses using chunked transfer-encoding WebServer 1.3: * Added logging in common log format * Added support for SSL/TLS via SqueakSSL. WebServer 1.2: * Added support for multipart/form-data posts * Added WebSocket support WebServer 1.1: * Added support for specific request methods * Implement HEAD, TRACE, and OPTIONS in WebServer WebServer 1.0: * Initial release. !!' readStream nextChunkText! ----- Method: WebServerHelp class>>cookies (in category 'pages') ----- cookies "This method was automatically generated. Edit it using:" "WebServerHelp edit: #cookies" ^HelpTopic title: 'Cookies' contents: 'Because of the performance issues with authentication, we''d like to avoid authentication for each request and instead authenticate once and use some persistent session state (cookies). So let''s do that: WebServer default addService: ''/smalltalk'' action:[:req| | session | session := WebServer default sessionAt: (req cookieAt: ''session''). session ifNil:[ "no session, reguire login" req send302Response: ''/login?url='', req rawUrl encodeForHTTP. ] ifNotNil:[ | target action | action := (req fields at: ''get'' ifAbsent:['''']) asSymbol. req send200Response: (Smalltalk perform: action) asString. ]. ]. And of course we now need a login service The service will require authentication and provide a session identifier for the client. It then redirects back to where the request was originally made from: WebServer default addService: ''/login'' action:[:req| | session | WebServer default authenticate: req realm: ''squeak'' methods: #(digest) do:[ | id | "We have no session state for now, just remember the session id" WebServer default sessionAt: (id := UUID new hex) put: ''''. "Send a redirect back to where we came from with a cookie" req send302Response: (req fields at: ''url'' ifAbsent:[''/'']) do:[:reply| reply setCookie: ''session'' value: id path: ''/smalltalk'']]]. !! ]style[(204 11 7 1 11 1 12 1 7 2 3 1 1 1 1 7 1 1 3 7 1 2 11 7 1 10 1 1 3 1 9 1 9 1 4 7 1 6 1 1 27 4 3 1 16 1 13 1 1 3 1 6 1 13 4 1 1 9 1 1 1 1 6 1 6 1 1 4 6 1 2 1 1 3 1 6 1 3 1 5 1 9 1 2 1 1 1 8 5 3 1 16 1 1 10 8 1 6 1 1 8 4 1 6 203 11 7 1 11 1 8 1 7 2 3 1 1 1 1 7 1 1 13 7 1 13 1 3 1 6 1 8 1 8 3 6 2 3 1 1 1 1 2 1 1 4 64 14 7 1 10 1 1 2 1 2 6 3 1 3 1 1 4 1 2 5 58 4 3 1 16 1 1 3 1 6 1 3 1 5 1 9 1 3 1 1 6 3 1 1 5 1 1 5 1 10 1 9 1 6 1 2 1 5 1 13 1 3),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,b,cblack;,c000000127,cblack;,c000000127,cblack;,c000127000,c000000127,cblack;,c000000127,cblack;,c127000127,c000127000,cblack;,cgray;,cblack;,c000000127,c000127000,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000127000,cblack;,c000000127,c000127000,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,b,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000000,c127000127,c127000000,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,cgray;,c127000127,cblack;,c000000127,cblack;,c000127000,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,c000127000,cblack;,cgray;,cblack;,cgray;,cblack;,cgray;,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cgray;,cblack;,b,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,c127000000,c127000127,c127000000,c127000127,cblack;,c000000127,c127000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,cgray;,cblack;,c000000127,cblack;,c127000127,c000127000,cblack;!!' readStream nextChunkText! ----- Method: WebServerHelp class>>errorHandling (in category 'pages') ----- errorHandling "This method was automatically generated. Edit it using:" "WebServerHelp edit: #errorHandling" ^HelpTopic title: 'Error Handling' contents: 'By default WebServer will send a 500 response with a full debug stack when an error occurs. This may not be appropriate in production environments and consequently, the error handler can be customized. Typically, the error handler will perform one of the following actions: * Pass the error through. This is useful for debugging, when an error in WebServer should raise a notifier: webServer errorHandler:[:err :socket| err pass]. * Send the ''standard'' 500 response (including the full stack): You can simply use WebServer''s default action for this: webServer errorHandler:[:err :socket| webServer handleError: err socket: socket.]. * Send a custom 500 response, or perform a redirect, for example: webServer errorHandler:[:err :socket| [socket sendData: ''HTTP/1.0 302 Temporary redirect'', String crlf, ''Location: /error.html'', String crlf, String crlf. socket close] on: Error do:[ "Ignore errors in error handling" ]. ]. Of course, you can use any possible combination; including the ability to turn error handling on and off via WebServer http requests.!! ]style[(384 11 13 2 3 2 6 1 1 3 1 4 2 123 10 13 2 3 2 6 1 11 12 1 3 1 7 1 6 3 69 11 13 2 3 2 6 1 3 1 6 1 9 4 33 1 8 5 4 23 1 8 5 11 4 4 6 1 5 1 1 3 7 3 1 4 33 3 1 5 135),cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cgray;,cblack;,c000000126,cblack;,c000000126,cblack;,,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cgray;,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cblack;,,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cgray;,cblack;,c000126000,c000000126,cblack;,c000000126,cblack;,c126000126,c000000126,cblack;,c000000126,cblack;,c126000126,c000000126,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,cblack;,c000000126,c000126000,cblack;,c000000126,cblack;,c000000126,c000126000,cblack;,c000126126,cblack;,c000126000,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>introduction (in category 'pages') ----- introduction "This method was automatically generated. Edit it using:" "WebServerHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'WebServer is a simple, yet reasonably complete HTTP server implementation. WebServer supports streaming, authentication, cookies, and session handling in a compact and easy to use form. The primary goal for WebServer is for command-and-control style interfaces. If you would like to add some web-based remote control facility without much fuzz and html goodness around it, WebServer is for you. WebServer comes together with WebClient which provides a similarly complete and simple HTTP client implementation.!!' readStream nextChunkText! ----- Method: WebServerHelp class>>logging (in category 'pages') ----- logging "This method was automatically generated. Edit it using:" "WebServerHelp edit: #logging" ^HelpTopic title: 'Logging' contents: 'WebServer supports logging in common log format. In order to tell WebServer where to log to you can either give it a stream: WebServer default accessLog: Transcript. or alternatively a file name, for example: WebServer default accessLog: ''/var/log/wsd/access_log''. When used in the latter form, WebServer opens and closes the file for each log entry which provides additional robustness at the cost of some performance. !! ]style[(126 11 7 1 10 12 46 11 7 1 10 1 25 1 157),cblack;,c000000127,cblack;,c000000127,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>pages (in category 'accessing') ----- pages "Returns a collection of method selectors to return the pages of the custom help book" ^#(introduction startingWebServer addingServices serviceHierarchies errorHandling addingActions authentication cookies summary logging sslSupport changeLog)! ----- Method: WebServerHelp class>>serviceHierarchies (in category 'pages') ----- serviceHierarchies "This method was automatically generated. Edit it using:" "WebServerHelp edit: #serviceHierarchies" ^HelpTopic title: 'Service Hierarchies' contents: 'More specific services are preferred over more general services. In addition to the /hello service, we can provide a handler for /hello/squeak by adding the following service: WebServer default addService: ''/hello/squeak'' action:[:req| req send200Response: ''Hello to you too, Squeak!!!!''. ]. (WebClient httpGet:''http://localhost:8080/hello'') content. (WebClient httpGet:''http://localhost:8080/hello/squeak'') content. A default handler for any kind of request can installed by using the ''/'' path: WebServer default addService: ''/'' action:[:req| req send302Response: ''/hello''. "temporary redirect" ]. This will make any request that isn''t handled by an explicit action redirect to /hello where it will be handled by the handler established earlier, for example: (WebClient httpGet:''http://localhost:8080/foobar'') content. !! ]style[(178 11 7 1 11 1 15 1 7 2 3 1 3 3 1 16 1 27 6 1 12 8 29 2 7 14 8 36 2 7 2 81 11 7 1 11 1 3 1 7 2 3 1 3 3 1 16 1 8 2 20 5 163 12 8 30 2 7 1 1),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c000000127,cgray;,cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000127127,cblack;,,cblack;,c000000127,c127000127,cblack;,c000000127,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>sslSupport (in category 'pages') ----- sslSupport "This method was automatically generated. Edit it using:" "WebServerHelp edit: #sslSupport" ^HelpTopic title: 'SSL/TLS Support' contents: 'WebServer supports secure connections over SSL/TLS via SqueakSSL. To install SqueakSSL, execute the following: (Installer ss project: ''SqueakSSL'') install: ''SqueakSSL-Core''; install: ''SqueakSSL-Tests''. If you have SqueakSSL installed, you can tell WebServer to use a particular cert which puts WebServer into secure mode. The certName itself is platform dependent. On Unix, the cert name is the path to the .pem file with BOTH the cert and the private key, for example: WebServer default certName: ''/home/user/certs/testcert.pem''. On Windows, the cert name is a string that is matched against the certificate subject. Usually, the certificate subject includes your host name so that you would use: WebServer default certName: ''secure.domain.com''. Client certificate handling is currently not supported. !! ]style[(112 12 2 1 8 1 11 4 8 1 16 4 8 1 17 1 272 11 7 1 9 1 31 1 170 11 7 1 9 1 19 1 58),cblack;,c000000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,c127000127,cblack;,,cblack;,c000000125,cblack;,c000000125,cblack;,c125000125,cblack;,,cblack;,c000000125,cblack;,c000000125,cblack;,c125000125,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>startingWebServer (in category 'pages') ----- startingWebServer "This method was automatically generated. Edit it using:" "WebServerHelp edit: #startingWebServer" ^HelpTopic title: 'Starting WebServer' contents: 'A WebServer is started by listening on a particular port. The examples below use ''WebServer reset default'' for convenience; specific applications should have their own registry for accessing various WebServer instances. (WebServer reset default) listenOn: 8080. The server will persist when the image is restarted and must be stopped explicitly by sending it the #destroy message. !! ]style[(221 12 5 1 7 4 9 1 4 2 120),cblack;,c000000127,cblack;,c000000127,cblack;,c000000127,cblack;,c127000000,cblack;,!!' readStream nextChunkText! ----- Method: WebServerHelp class>>summary (in category 'pages') ----- summary "This method was automatically generated. Edit it using:" "WebServerHelp edit: #summary" ^HelpTopic title: 'Summary' contents: 'At this point, making a request like the following: (WebClient httpGet: ''http://localhost:8080/smalltalk?get=platformName'') content. requires several roundtrips: 1) The first GET request is redirected from /smalltalk to /login 2) The request to /login is responded to with an authentication challenge 3) The request to /login is authenticated and a session cookie is established 4) The request is redirected back to /smalltalk where it is finally handled. More examples for using WebServer can be found in class WebServer itself. Here is an overview: * exampleDoIt - the simplest possible RPC interface to Squeak. * exampleBrowse - browse the files on your local disk * exampleSession - a simple session example * exampleAuth - a simple authentication example !! ]style[(53 12 8 1 50 2 7 2 639),cblack;,c000000127,cblack;,c127000127,cblack;,c000000127,cblack;,!!' readStream nextChunkText! WebServerHelp subclass: #WebServerReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'WebClient-Help'! ----- Method: WebServerReference class>>bookName (in category 'accessing') ----- bookName ^'Reference'! ----- Method: WebServerReference class>>builder (in category 'accessing') ----- builder ^PackageAPIHelpBuilder! ----- Method: WebServerReference class>>packages (in category 'accessing') ----- packages ^#('WebClient-Core')! From commits at source.squeak.org Fri Jun 5 20:15:51 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:15:53 2015 Subject: [squeak-dev] Squeak 4.6: Exceptions-cmm.49.mcz Message-ID: Chris Muller uploaded a new version of Exceptions to project Squeak 4.6: http://source.squeak.org/squeak46/Exceptions-cmm.49.mcz ==================== Summary ==================== Name: Exceptions-cmm.49 Author: cmm Time: 23 January 2014, 10:54:37.468 am UUID: 6cede9fe-b13d-481a-b8de-bb004ece1145 Ancestors: Exceptions-fbs.48 Remove unused categories. ==================== Snapshot ==================== From commits at source.squeak.org Fri Jun 5 20:16:30 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:16:35 2015 Subject: [squeak-dev] Squeak 4.6: Installer-Core-cmm.397.mcz Message-ID: Chris Muller uploaded a new version of Installer-Core to project Squeak 4.6: http://source.squeak.org/squeak46/Installer-Core-cmm.397.mcz ==================== Summary ==================== Name: Installer-Core-cmm.397 Author: cmm Time: 13 April 2015, 8:28:57.87 pm UUID: e3825d75-2e08-4420-b2d0-25d7946a4371 Ancestors: Installer-Core-cmm.396 SqueakSource employs server-specific versions of OSProcess and RFB. ==================== Snapshot ==================== SystemOrganization addCategory: #'Installer-Core'! Object subclass: #Installer instanceVariableNames: 'answers packages messagesToSuppress useFileIn noiseLevel currentRepository' classVariableNames: 'InstallerBindings IsSetToTrapErrors Repositories SkipLoadingTests ValidationBlock' poolDictionaries: '' category: 'Installer-Core'! !Installer commentStamp: 'kph 3/30/2009 01:29' prior: 0! Documentation now available at http://installer.pbwiki.com/Installer useFileIn - flag to load source.st rather than using Monticello! ----- Method: Installer class>>actionMatch:reportOn:ifNoMatch: (in category 'action report') ----- actionMatch: theLine reportOn: report ifNoMatch: aBlock | line | line := theLine withBlanksCondensed. self allSubclassesDo: [:class | (class canReportLine: line) ifTrue: [ ^ class new action: theLine reportOn: report ]]. ^ aBlock value! ----- Method: Installer class>>airplaneMode (in category 'repository-overrides') ----- airplaneMode "Override all remote repositories with the package cache." self overrideRemoteRepostoriesWith: MCCacheRepository default! ----- Method: Installer class>>bootstrapTheRestOfInstaller (in category 'action report') ----- bootstrapTheRestOfInstaller (Installer url: 'www.squeaksource.com/Installer/Installer-Scripts') fileInSource; logCR: 'installer bootstrap - loaded'.! ----- Method: Installer class>>bug:fix: (in category 'mantis') ----- bug: n fix: filename Transcript cr; show: 'Code script in Mantis:', n asString, ' should read Installer mantis bug: ',n asString, ' fix: ', filename printString,'.'. ^ self mantis bug: n fix: filename! ----- Method: Installer class>>cache (in category 'monticello') ----- cache ^ self monticello cache! ----- Method: Installer class>>canReportLine: (in category 'action report') ----- canReportLine: line ^ false! ----- Method: Installer class>>cancelSkipLoadingTests (in category 'accessing') ----- cancelSkipLoadingTests "sets a flag to un-ignore loading of the testing portion of scripts embedded in pages" SkipLoadingTests := false. ! ----- Method: Installer class>>clearOverrides (in category 'repository-overrides') ----- clearOverrides "Remove all repository overrides and load everthing from the specified default repositories when using #merge:." Repositories := Dictionary new! ----- Method: Installer class>>cobalt (in category 'repositories') ----- cobalt ^ self monticello http: 'http://croquet-src-01.oit.duke.edu:8886'! ----- Method: Installer class>>debug (in category 'debug') ----- debug IsSetToTrapErrors := false! ----- Method: Installer class>>defaultRepositoryFor: (in category 'private') ----- defaultRepositoryFor: anAssociation "private -- answer the MC repository specified by anAssociation." ^ (self perform: anAssociation key) project: anAssociation value ; mc! ----- Method: Installer class>>do: (in category 'launcher support') ----- do: webPageName | rs | rs := webPageName readStream. [ rs atEnd ] whileFalse: [ self install: (rs upTo: $;) ]. ! ----- Method: Installer class>>file (in category 'file') ----- file ^ InstallerFile new! ----- Method: Installer class>>file: (in category 'file') ----- file: fileName ^ InstallerFile new file: fileName; yourself ! ----- Method: Installer class>>fromUrl: (in category 'url') ----- fromUrl: aUrl "try and pick an Installer appropriate for the Url" | inst | ((aUrl endsWith: '.mcz') or: [ aUrl endsWith: '.mcm' ]) ifTrue: [ inst := Installer mc fromUrl: aUrl. inst packages isEmpty ifFalse: [ ^ inst ] ] . ^ Installer url: aUrl ! ----- Method: Installer class>>gemsource (in category 'repositories') ----- gemsource ^ self monticello http: 'http://seaside.gemstone.com/ss'! ----- Method: Installer class>>goran (in category 'repositories') ----- goran ^ self monticello http: 'squeak.krampe.se'; project: ''! ----- Method: Installer class>>gs (in category 'repositories') ----- gs ^ self gemsource! ----- Method: Installer class>>impara (in category 'repositories') ----- impara ^ self monticello http: 'source.impara.de'! ----- Method: Installer class>>install: (in category 'action report') ----- install: scriptName ^ (self scripts install: scriptName) ifNil:[ self web install: scriptName ] ! ----- Method: Installer class>>installFile: (in category 'file') ----- installFile: fileName ^ (self file: fileName) install. ! ----- Method: Installer class>>installSilentlyUrl: (in category 'url') ----- installSilentlyUrl: urlString ^ SystemChangeNotifier uniqueInstance doSilently: [ self url url: urlString; install ]. ! ----- Method: Installer class>>installUrl: (in category 'url') ----- installUrl: urlString ^ self url url: urlString; install. ! ----- Method: Installer class>>keith (in category 'repositories') ----- keith ^ self monticello ftp: 'squeak.warwick.st' directory: 'mc' user: 'squeak' password: 'viewpoints'! ----- Method: Installer class>>krestianstvo (in category 'repositories') ----- krestianstvo "Krestianstvo SDK code repository." ^ self monticello http: 'http://sdk.krestianstvo.org/sdk/'! ----- Method: Installer class>>launchFrom: (in category 'launcher support') ----- launchFrom: launcher ^self launchWith: launcher getParameters! ----- Method: Installer class>>launchHelp (in category 'launcher support') ----- launchHelp ^'path=/dir/*.txt Specify a search path for the item to install p=/dir1/*.txt;/ Multiple items delimited by ; The page name is typically appended to the path string, or if a "*" is present, it will be replaced by the page name. in,i,install= Page appended to the path to begin the install process url,u= Install using an explicit url from which to obtain a script or file file= Install using a local file +debug Do not trap errors view= Print the script that would have been installed. For more options use Script eval="Installer ... " ' ! ----- Method: Installer class>>launchWith: (in category 'launcher support') ----- launchWith: params params at: 'P' ifPresent: [ :v | params at: 'PATH' put: v ]. params at: 'I' ifPresent: [ :v | params at: 'INSTALL' put: v ]. params at: 'IN' ifPresent: [ :v | params at: 'INSTALL' put: v ]. params at: 'U' ifPresent: [ :v | params at: 'URL' put: v ]. params at: 'PATH' ifPresent: [ :v | self webSearchPathFrom: v. ]. params at: 'USER' ifPresent: [ :v | Utilities setAuthorInitials: v ]. params at: 'VERSION' ifPresent: [ :v | SystemVersion current version: v ]. params at: 'VIEW' ifPresent: [ :v | self view: v ]. IsSetToTrapErrors := true. params at: 'DEBUG' ifPresent: [ :v | IsSetToTrapErrors := (v == true) not ]. params at: 'URL' ifPresent: [ :v | self installUrl: v ]. params at: 'FILE' ifPresent: [ :v | self installFile: v ]. params at: 'INSTALL' ifPresent: [ :v | self do: v ]. params at: 'DO' ifPresent: [ :v | self do: v ]. ^true ! ----- Method: Installer class>>log: (in category 'logging') ----- log: aString Transcript show: aString; cr.! ----- Method: Installer class>>lukas (in category 'repositories') ----- lukas ^ self monticello http: 'http://source.lukas-renggli.ch'! ----- Method: Installer class>>mantis (in category 'mantis') ----- mantis ^ self mantis: 'http://bugs.squeak.org/'! ----- Method: Installer class>>mantis: (in category 'mantis') ----- mantis: host ^ InstallerMantis host: host! ----- Method: Installer class>>mc (in category 'monticello') ----- mc ^ self monticello! ----- Method: Installer class>>monticello (in category 'monticello') ----- monticello ^ InstallerMonticello new! ----- Method: Installer class>>noDebug (in category 'debug') ----- noDebug IsSetToTrapErrors := true! ----- Method: Installer class>>noProgressDuring: (in category 'during') ----- noProgressDuring: block [ block value: self ] on: ProgressInitiationException do: [ : note | note sendNotificationsTo: [ :min :max :curr | "ignore" ] ]! ----- Method: Installer class>>overrideRemoteRepostoriesWith: (in category 'repository-overrides') ----- overrideRemoteRepostoriesWith: aMCRepositoryOrGroup self remoteRepositories do: [ : each | self overrideRepository: each with: aMCRepositoryOrGroup ]! ----- Method: Installer class>>overrideRepository:with: (in category 'repository-overrides') ----- overrideRepository: scope with: anMCRepository "When configuring the image with #merge:, override the standard repository specified by scope with anMCRepository." "Installer override: #ss3->'htmlcssparser' with: (MCDirectoryRepository directory: (FileDirectory default / 'mc'))." "Installer override: #ss with: #ssMirror." self repositories at: scope put: anMCRepository! ----- Method: Installer class>>packageCache (in category 'repositories') ----- packageCache ^ MCCacheRepository default! ----- Method: Installer class>>path: (in category 'web') ----- path: aString "convenience abbreviation" self webSearchPathFrom: aString! ----- Method: Installer class>>privateUpgradeTheRest (in category 'instanciation') ----- privateUpgradeTheRest Installer ss project: 'Installer'; installQuietly: 'Installer-Scripts'; installQuietly: 'Installer-Formats'.. ^ self! ----- Method: Installer class>>remoteRepositories (in category 'repository-overrides') ----- remoteRepositories ^ #(#ss #ss3 #cobalt #gemsource #goran #gs #impara #keith #krestianstvo #lukas #saltypickle #sophie #squeak #squeakfoundation #squeaksource #squeaksource3 #ss #ss3 #swa #swasource #wiresong )! ----- Method: Installer class>>removeOverride: (in category 'repository-overrides') ----- removeOverride: scope "Remove override specified by scope and return to using the default repository for packages within that scope." ^ self repositories removeKey: scope ifAbsent: [ ]! ----- Method: Installer class>>repositories (in category 'accessing') ----- repositories ^ Repositories ifNil: [ Repositories := Dictionary new ]! ----- Method: Installer class>>repository: (in category 'monticello') ----- repository: host ^self monticello http: host ! ----- Method: Installer class>>repositoryFor: (in category 'private') ----- repositoryFor: anAssociation "private -- anAssociation key is the repository selector Symbol understood by Intsaller class. It's value is the project name within that HTTP repository." | rep | rep := self repositories at: anAssociation "<-- check for #rep->project overrides first" ifAbsent: [ self repositories at: anAssociation key "<-- override an entire repository." ifAbsent: [ ^ self defaultRepositoryFor: anAssociation ] ]. ^ rep isSymbol ifTrue: [ self defaultRepositoryFor: rep -> anAssociation value ] ifFalse: [ rep ]! ----- Method: Installer class>>sake (in category 'sake') ----- sake ^ self sake: InstallerSake sake! ----- Method: Installer class>>sake: (in category 'sake') ----- sake: aSakePackagesClass ^ InstallerSake new sake: aSakePackagesClass! ----- Method: Installer class>>saltypickle (in category 'repositories') ----- saltypickle ^ self monticello http: 'squeak.saltypickle.com'! ----- Method: Installer class>>setSakeToUse: (in category 'sake') ----- setSakeToUse: aClass InstallerSake sake: aClass! ----- Method: Installer class>>sf (in category 'documentation') ----- sf ^ self squeakfoundation ! ----- Method: Installer class>>skipLoadingTests (in category 'accessing') ----- skipLoadingTests "sets a flag to ignore loading of the testing portion of scripts embedded in pages" SkipLoadingTests := true. ! ----- Method: Installer class>>skipLoadingTestsDuring: (in category 'during') ----- skipLoadingTestsDuring: block | oldValue | oldValue := SkipLoadingTests. SkipLoadingTests := true. [ block value: self ] ensure:[ SkipLoadingTests := oldValue ].! ----- Method: Installer class>>sm (in category 'squeakmap') ----- sm ^ self squeakmap! ----- Method: Installer class>>sophie (in category 'repositories') ----- sophie ^ self monticello http: 'source.sophieproject.org' ! ----- Method: Installer class>>squeak (in category 'repositories') ----- squeak ^self monticello http: 'source.squeak.org'! ----- Method: Installer class>>squeakInbox (in category 'repositories') ----- squeakInbox ^self squeak project: 'inbox'! ----- Method: Installer class>>squeakTrunk (in category 'repositories') ----- squeakTrunk ^self squeak project: 'trunk'! ----- Method: Installer class>>squeakfoundation (in category 'repositories') ----- squeakfoundation ^ self monticello http: 'source.squeakfoundation.org'! ----- Method: Installer class>>squeakmap (in category 'squeakmap') ----- squeakmap ^ InstallerSqueakMap new sm: true; yourself! ----- Method: Installer class>>squeaksource (in category 'repositories') ----- squeaksource ^ self monticello http: 'http://www.squeaksource.com'! ----- Method: Installer class>>squeaksource3 (in category 'repositories') ----- squeaksource3 ^ self monticello http: 'http://ss3.gemtalksystems.com/ss/'! ----- Method: Installer class>>ss (in category 'repositories') ----- ss ^ self squeaksource ! ----- Method: Installer class>>ss3 (in category 'repositories') ----- ss3 ^ self squeaksource3.! ----- Method: Installer class>>ssMirror (in category 'repositories') ----- ssMirror "The Chilean mirror for the original SqueakSource." ^ self monticello http: 'http://dsal.cl/squeaksource/'! ----- Method: Installer class>>swa (in category 'repositories') ----- swa ^ self swasource! ----- Method: Installer class>>swasource (in category 'repositories') ----- swasource ^ self monticello http: 'http://www.hpi.uni-potsdam.de/hirschfeld/squeaksource'! ----- Method: Installer class>>universe (in category 'universe') ----- universe ^ InstallerUniverse default! ----- Method: Installer class>>upgrade (in category 'instanciation') ----- upgrade Installer ss project: 'Installer'; installQuietly: 'Installer-Core'. self privateUpgradeTheRest. ^ self! ----- Method: Installer class>>url (in category 'url') ----- url ^ InstallerUrl new url: ''! ----- Method: Installer class>>url: (in category 'url') ----- url: urlString ^self url url: urlString; yourself! ----- Method: Installer class>>validationBlock (in category 'accessing') ----- validationBlock ^ ValidationBlock! ----- Method: Installer class>>validationBlock: (in category 'accessing') ----- validationBlock: aBlock ValidationBlock := aBlock! ----- Method: Installer class>>view: (in category 'instanciation') ----- view: webPageNameOrUrl | theReport | theReport := String streamContents: [ :report | (webPageNameOrUrl beginsWith: 'http://') ifTrue: [ self actionMatch: ('Installer installUrl: ', (webPageNameOrUrl printString),'.') reportOn: report ifNoMatch: [] ] ifFalse: [ self actionMatch: ('Installer install: ', (webPageNameOrUrl printString),'.') reportOn: report ifNoMatch: [] ]]. Workspace new contents: (theReport contents); openLabel: webPageNameOrUrl. ^theReport contents ! ----- Method: Installer class>>web (in category 'web') ----- web ^ InstallerWeb! ----- Method: Installer class>>webInstall: (in category 'web') ----- webInstall: webPageName ^ self web install: webPageName ! ----- Method: Installer class>>webSearchPath (in category 'web') ----- webSearchPath "a search path item, has the following format. prefix*suffix" ^ self web searchPath! ----- Method: Installer class>>webSearchPathFrom: (in category 'web') ----- webSearchPathFrom: string | reader wsp path | reader := string readStream. wsp := self webSearchPath. [ reader atEnd ] whileFalse: [ path := reader upTo: $;. (wsp includes: wsp) ifFalse: [ wsp addFirst: path ]]. ! ----- Method: Installer class>>websqueakmap (in category 'websqueakmap') ----- websqueakmap ^ InstallerWebSqueakMap new wsm: 'http://map.squeak.org'; yourself! ----- Method: Installer class>>websqueakmap: (in category 'websqueakmap') ----- websqueakmap: host ^ InstallerWebSqueakMap new wsm: host; yourself! ----- Method: Installer class>>wiresong (in category 'repositories') ----- wiresong ^ self monticello http: 'http://source.wiresong.ca'! ----- Method: Installer class>>wsm (in category 'websqueakmap') ----- wsm ^ self websqueakmap! ----- Method: Installer>>addPackage: (in category 'public interface') ----- addPackage: anObject self packages add: anObject! ----- Method: Installer>>allPackages (in category 'accessing') ----- allPackages ^ (self class withAllSuperclasses inject: OrderedCollection new into: [ : coll : each | coll addAll: (each methodsInCategory: 'package-definitions') ; yourself ]) sort! ----- Method: Installer>>answer:with: (in category 'auto answering') ----- answer: aString with: anAnswer ^self answers add: ( Array with: aString with: anAnswer )! ----- Method: Installer>>answers (in category 'accessing') ----- answers ^ answers ifNil: [ answers := OrderedCollection new ]! ----- Method: Installer>>answers: (in category 'accessing') ----- answers: anObject answers := anObject! ----- Method: Installer>>availablePackages (in category 'public interface') ----- availablePackages ^ self basicAvailablePackages! ----- Method: Installer>>basicAvailablePackages (in category 'basic interface') ----- basicAvailablePackages! ----- Method: Installer>>basicBrowse (in category 'basic interface') ----- basicBrowse! ----- Method: Installer>>basicInstall (in category 'basic interface') ----- basicInstall! ----- Method: Installer>>basicVersions (in category 'basic interface') ----- basicVersions! ----- Method: Installer>>basicView (in category 'basic interface') ----- basicView! ----- Method: Installer>>bindingOf: (in category 'script bindings') ----- bindingOf: aString self isThisEverCalled: 'Want to get rid of this and the class-var'. InstallerBindings isNil ifTrue: [ InstallerBindings := Dictionary new]. (InstallerBindings includesKey: aString) ifFalse: [InstallerBindings at: aString put: nil]. ^ InstallerBindings associationAt: aString.! ----- Method: Installer>>bootstrap (in category 'public interface') ----- bootstrap "keep for compatability" self deprecatedApi. useFileIn := true. self install.! ----- Method: Installer>>broomMorphsBase (in category 'package-definitions') ----- broomMorphsBase "Morph alignment user-interface tool." ^ { #ss3 -> 'Connectors'. 'BroomMorphs-Base' }! ----- Method: Installer>>browse (in category 'public interface') ----- browse self logErrorDuring: [self basicBrowse]! ----- Method: Installer>>browse: (in category 'public interface') ----- browse: packageNameCollectionOrDetectBlock self package: packageNameCollectionOrDetectBlock. self browse! ----- Method: Installer>>browse:from: (in category 'mantis') ----- browse: aFileName from: stream | mcThing ext browseSelector | self log: ' browsing...'. mcThing := self classMCReader ifNotNil: [ self mcThing: aFileName from: stream ]. mcThing ifNotNil: [ (mcThing respondsTo: #snapshot) ifTrue: [ mcThing browse ] ifFalse: [ (MCSnapshotBrowser forSnapshot: mcThing) showLabelled: 'Browsing ', aFileName ] ] ifNil: [ ext := aFileName copyAfterLast: $.. browseSelector := ('browse', ext asUppercase, ':from:') asSymbol. (self respondsTo: browseSelector) ifTrue: [ self perform: browseSelector with: aFileName with: stream ] ifFalse: [ self browseDefault: aFileName from: stream ]. ]! ----- Method: Installer>>browseCS:from: (in category 'mantis') ----- browseCS: aFileName from: stream | list | list := self classChangeList new scanFile: stream from: 1 to: stream size. self classChangeList open: list name: aFileName multiSelect: true. ! ----- Method: Installer>>browseDefault:from: (in category 'mantis') ----- browseDefault: aFileName from: stream self view: aFileName from: stream! ----- Method: Installer>>browseGZ:from: (in category 'mantis') ----- browseGZ: aFileName from: stream "FileIn the contents of a gzipped stream" | zipped unzipped | zipped := self classGZipReadStream on: stream. unzipped := MultiByteBinaryOrTextStream with: zipped contents asString. unzipped reset. ChangeList browseStream: unzipped ! ----- Method: Installer>>changeSetNamed: (in category 'utils') ----- changeSetNamed: aName (ChangeSet respondsTo: #named:) ifTrue: [ ^ ChangeSet named: aName ]. ^ ChangeSorter changeSetNamed: aName.! ----- Method: Installer>>classChangeList (in category 'class references') ----- classChangeList ^Smalltalk at: #ChangeList ifAbsent: [ self error: 'ChangeList not present' ]! ----- Method: Installer>>classChangeSet (in category 'class references') ----- classChangeSet ^Smalltalk at: #ChangeSet ifAbsent: [ self error: 'ChangeSet not present' ]! ----- Method: Installer>>classChangeSorter (in category 'class references') ----- classChangeSorter ^Smalltalk at: #ChangeSorter ifAbsent: [ self error: 'ChangeSorter not present' ]! ----- Method: Installer>>classGZipReadStream (in category 'class references') ----- classGZipReadStream ^Smalltalk at: #GZipReadStream ifAbsent: [ self error: 'Compression not present' ]! ----- Method: Installer>>classMCReader (in category 'class references') ----- classMCReader ^Smalltalk at: #MCReader ifAbsent: [ nil ] ! ----- Method: Installer>>classMczInstaller (in category 'class references') ----- classMczInstaller ^Smalltalk at: #MczInstaller ifAbsent: [ nil ] ! ----- Method: Installer>>classMultiByteBinaryOrTextStream (in category 'class references') ----- classMultiByteBinaryOrTextStream ^Smalltalk at: #MultiByteBinaryOrTextStream ifAbsent: [ self error: 'MultiByteBinaryOrTextStream not present' ]! ----- Method: Installer>>classSARInstaller (in category 'class references') ----- classSARInstaller ^Smalltalk at: #SARInstaller ifAbsent: [ self error: 'SARInstaller not present' ]! ----- Method: Installer>>connectors (in category 'package-definitions') ----- connectors "Connect Morphs together. Make diagrams." ^ { self broomMorphsBase. 'CGPrereqs'. 'FSM'. 'Connectors'. 'ConnectorsText'. 'ConnectorsShapes'. 'ConnectorsTools'. 'ConnectorsGraphLayout'. 'BroomMorphs-Connectors' }! ----- Method: Installer>>core (in category 'package-definitions') ----- core "A minimum core capable of expanding itself." ^ { #squeak -> MCMcmUpdater defaultUpdateURL asUrl path last. 'Kernel'. 'Collections'. 'Exceptions'. 'Files'. 'Network'. 'Monticello'. 'MonticelloConfigurations'. 'Installer-Core' }! ----- Method: Installer>>curvedSpaceExplorer (in category 'package-definitions') ----- curvedSpaceExplorer "Explore curved 3D spaces." ^ { self openGL. 'CCSpaceExplorer' }! ----- Method: Installer>>depthFirstOf:do: (in category 'private') ----- depthFirstOf: structure do: oneArgBlock self depthFirstOf: structure do: oneArgBlock ifNotIn: Set new! ----- Method: Installer>>depthFirstOf:do:ifNotIn: (in category 'private') ----- depthFirstOf: structure do: oneArgBlock ifNotIn: aSet (aSet includes: structure) ifTrue: [ ^ self ]. "Respect all repository directives even if encountered more than once." (structure isVariableBinding) ifFalse: [ aSet add: structure ]. structure isArray ifTrue: [ structure do: [ : each | self depthFirstOf: each do: oneArgBlock ifNotIn: aSet ] ] ifFalse: [ oneArgBlock value: structure ]! ----- Method: Installer>>ditchOldChangeSetFor: (in category 'utils') ----- ditchOldChangeSetFor: aFileName | changeSetName changeSet | changeSetName := (self validChangeSetName: aFileName) sansPeriodSuffix. changeSet := self changeSetNamed: changeSetName. changeSet ifNotNil: [ (self logCR:'Removing old change set ', changeSetName) cr. self removeChangeSet: changeSet ].! ----- Method: Installer>>ffi (in category 'package-definitions') ----- ffi "Foreign Function Interface." ^ { #squeak -> 'FFI'. 'FFI-Pools'. 'FFI-Kernel' }! ----- Method: Installer>>ffiTests (in category 'package-definitions') ----- ffiTests "Tests for Foreign Function Interface." ^ { self ffi. 'FFI-Tests' }! ----- Method: Installer>>fileInSource (in category 'public interface') ----- fileInSource useFileIn := true. self install.! ----- Method: Installer>>fuel (in category 'package-definitions') ----- fuel "Serialization package." ^ { #ss3 -> 'Fuel'. 'ConfigurationOfFuel' }! ----- Method: Installer>>htmlValidator (in category 'package-definitions') ----- htmlValidator "Validates HTML and CSS pages against W3C DTD." ^ { #ss3 -> 'htmlcssparser'. 'HTML' }! ----- Method: Installer>>initialize (in category 'public interface') ----- initialize useFileIn := false..! ----- Method: Installer>>install (in category 'public interface') ----- install noiseLevel = #quiet ifTrue: [ ^ self installQuietly ]. noiseLevel = #silent ifTrue: [ ^ self installSilently ]. ^ self installLogging! ----- Method: Installer>>install: (in category 'public interface') ----- install: packageNameCollectionOrDetectBlock "The parameter specifies the package to be installed in one of the following ways: - By Name e.g. install: 'Kernel' - Acceptable Versions e.g. install: #('Comet-lr' 'Comet-pmm') i.e. either of these - Specific version e.g. install: 'Scriptaculous-lr.148' - By Predicate e.g. install: [ :packageName | packageName beginsWith: 'Dynamic' ]" self addPackage: packageNameCollectionOrDetectBlock. self install! ----- Method: Installer>>install:from: (in category 'mantis') ----- install: aFileName from: stream self log: ' installing...'. self withAnswersDo: [ | ext installSelector mcThing | mcThing := self classMCReader ifNotNil: [ self mcThing: aFileName from: stream ]. mcThing ifNotNil: [ (mcThing respondsTo: #install) ifTrue: [ mcThing install ] ifFalse: [ (mcThing respondsTo: #load) ifTrue: [ mcThing load ] ] ] ifNil: [ ext := (aFileName copyAfterLast: $/) in: [ :path | path isEmpty ifTrue: [ aFileName ] ifFalse: [ path ] ]. ext := ext copyAfterLast: $.. ext = '' ifTrue: [ ext := 'st' ]. installSelector := ('install', ext asUppercase, ':from:') asSymbol. useFileIn ifTrue: [ [ SystemChangeNotifier uniqueInstance doSilently: [self install: aFileName from: stream using: installSelector ]] on: Warning do: [ :ex | ex resume: true ]. ] ifFalse: [ self install: aFileName from: stream using: installSelector. ] ] ]. self log: ' done.' ! ----- Method: Installer>>install:from:using: (in category 'mantis') ----- install: aFileName from: stream using: installSelector (self respondsTo: installSelector) ifTrue: [ self perform: installSelector with: aFileName with: stream ] ifFalse: [ self installDefault: aFileName from: stream ]. ! ----- Method: Installer>>installCS:from: (in category 'mantis') ----- installCS: aFileName from: stream self ditchOldChangeSetFor: aFileName. self newChangeSetFromStream: stream named: (self validChangeSetName: aFileName). ! ----- Method: Installer>>installDefault:from: (in category 'mantis') ----- installDefault: aFileName from: stream "Check for UTF-8 input before filing it in" | pos | pos := stream position. (stream next: 3) asByteArray = #[16rEF 16rBB 16rBF] "BOM" ifTrue: [(RWBinaryOrTextStream on: stream upToEnd utf8ToSqueak) fileIn] ifFalse: [stream position: pos; fileIn] ! ----- Method: Installer>>installGZ:from: (in category 'mantis') ----- installGZ: aFileName from: stream "FileIn the contents of a gzipped stream" | zipped unzipped | zipped := self classGZipReadStream on: stream. unzipped := MultiByteBinaryOrTextStream with: zipped contents asString. unzipped reset. self newChangeSetFromStream: unzipped named: (FileDirectory localNameFor: aFileName)! ----- Method: Installer>>installLogging (in category 'public interface') ----- installLogging self logErrorDuring: [ self basicInstall. packages := nil]. ! ----- Method: Installer>>installMCZ:from: (in category 'mantis') ----- installMCZ: aFileName from: stream | source pkg wc | pkg := aFileName copyUpToLast: $-. wc := Smalltalk at: #MCWorkingCopy ifAbsent: [ nil ]. wc ifNotNil: [ (wc allManagers select: [:each | each packageName = pkg ]) do: [ :ea | ea unregister ] ]. self classMczInstaller ifNotNil: [^ self classMczInstaller install: aFileName stream: stream]. source := ((ZipArchive new readFrom:stream) memberNamed: 'snapshot/source.st') contents. [ SystemChangeNotifier uniqueInstance doSilently: [ source readStream fileInAnnouncing: 'Booting ' , aFileName. ] ] on: Warning do: [ :ex | ex resume: true ].! ----- Method: Installer>>installMCZBasic:from: (in category 'mantis') ----- installMCZBasic: aFileName from: stream | source | self classMczInstaller ifNotNil: [^ self classMczInstaller install: aFileName stream: stream]. source := ((ZipArchive new readFrom:stream) memberNamed: 'snapshot/source.st') contents. [ SystemChangeNotifier uniqueInstance doSilently: [ source readStream fileInAnnouncing: 'Booting ' , aFileName. ] ] on: Warning do: [ :ex | ex resume: true ].! ----- Method: Installer>>installMCcs:from: (in category 'mantis') ----- installMCcs: aFileName from: stream | reader | reader := Smalltalk at: #MCCsReader ifPresent: [:class | class on: stream].! ----- Method: Installer>>installQuietly (in category 'public interface') ----- installQuietly [ self installLogging ] on: Warning do: [ :ex | ex resume: true ].! ----- Method: Installer>>installQuietly: (in category 'public interface') ----- installQuietly: packageNameCollectionOrDetectBlock self quietly install: packageNameCollectionOrDetectBlock. ! ----- Method: Installer>>installSAR:from: (in category 'mantis') ----- installSAR: aFileName from: stream | newCS | newCS := self classSARInstaller withCurrentChangeSetNamed: aFileName do: [:cs | self classSARInstaller new fileInFrom: stream]. newCS isEmpty ifTrue: [ self removeChangeSet: newCS ]! ----- Method: Installer>>installSilently (in category 'public interface') ----- installSilently SystemChangeNotifier uniqueInstance doSilently: [ self installLogging ] ! ----- Method: Installer>>isSkipLoadingTestsSet (in category 'accessing') ----- isSkipLoadingTestsSet ^SkipLoadingTests ifNil: [ false ]! ----- Method: Installer>>log: (in category 'logging') ----- log: text ^Transcript show: text.! ----- Method: Installer>>logCR: (in category 'logging') ----- logCR: text self validate. ^ Transcript show: text; cr! ----- Method: Installer>>logErrorDuring: (in category 'logging') ----- logErrorDuring: block (IsSetToTrapErrors = true) ifFalse: [ ^ block value ]. block on: Error do: [ :e | self halt. self logCR: '****', e class name, ': ', (e messageText ifNil: [ '']). (e isKindOf: MessageNotUnderstood) ifTrue: [ e pass ] ifFalse: [ e isResumable ifTrue:[ e resume: true ]]]! ----- Method: Installer>>maInstaller (in category 'package-definitions') ----- maInstaller "Select from a family of related packages for application development." ^ { #ss3 -> 'Ma-Installer'. 'Ma-Installer-Core' }! ----- Method: Installer>>match: (in category 'searching') ----- match: aMatch ^self packagesMatching: aMatch! ----- Method: Installer>>mathMorphs (in category 'package-definitions') ----- mathMorphs "MathMorphs is a project that combines mathematics and Smalltalk. See http://www.dm.uba.ar/MathMorphs/ and chapter 10 of the 'new blue book'." ^ { self morphicWrappers. 'Functions' }! ----- Method: Installer>>mcThing:from: (in category 'mantis') ----- mcThing: aFileName from: stream "dont use monticello for .cs or for .st use monticello for .mcs" | reader | useFileIn ifTrue: [ ^ nil ]. reader := self classMCReader readerClassForFileNamed: aFileName. reader name = 'MCStReader' ifTrue: [ ^ nil ]. reader ifNil: [ ^ nil ]. (reader respondsTo: #on:fileName:) ifTrue: [ reader := reader on: stream fileName: aFileName. ^ reader version ] ifFalse: [ reader := reader on: stream. ^ reader snapshot ].! ----- Method: Installer>>merge: (in category 'public interface') ----- merge: structureOrSymbol | toUncache | toUncache := Set new. structureOrSymbol isSymbol ifTrue: [ self merge: (self perform: structureOrSymbol) ] ifFalse: [ self depthFirstOf: structureOrSymbol do: [ : each | each isVariableBinding ifTrue: [ currentRepository := self class repositoryFor: each. currentRepository cacheAllFilenames. toUncache add: currentRepository ] ifFalse: [ each isString ifTrue: [ self primMerge: each ] ifFalse: [ self error: 'invalid specification' ] ] ] ]. toUncache do: [ : each | each flushAllFilenames ]! ----- Method: Installer>>messagesToSuppress (in category 'accessing') ----- messagesToSuppress ^ messagesToSuppress ifNil: [ messagesToSuppress := OrderedCollection new ]! ----- Method: Installer>>messagesToSuppress: (in category 'accessing') ----- messagesToSuppress: anObject messagesToSuppress := anObject! ----- Method: Installer>>morphicWrappers (in category 'package-definitions') ----- morphicWrappers "Provides 'type on air' workspaces. Results of evaluated expressions are represented as domain objects in the world." ^ { #ss -> 'MathMorphsRevival'. 'MorphicWrappers' }! ----- Method: Installer>>newChangeSetFromStream:named: (in category 'mantis') ----- newChangeSetFromStream: aStream named: aName "This code is based upon ChangeSet-c-#newChangesFromStream:named: which is in 3.9, implemented here for previous versions. The second branch is for 3.8, where ChangeSets are loaded by ChangeSorter. " | oldChanges newName newSet | (self classChangeSet respondsTo: #newChangesFromStream:named:) ifTrue: [ ^self classChangeSet newChangesFromStream: aStream named:aName ]. (self classChangeSorter respondsTo: #newChangesFromStream:named:) ifTrue: [ ^self classChangeSorter newChangesFromStream: aStream named: aName ]. oldChanges := ChangeSet current. "so a Bumper update can find it" newName := aName sansPeriodSuffix. newSet := self classChangeSet basicNewNamed: newName. [ | newStream | newSet ifNotNil: [(aStream respondsTo: #converter:) ifTrue: [newStream := aStream] ifFalse: [newStream := self classMultiByteBinaryOrTextStream with: aStream contentsOfEntireFile. newStream reset]. self classChangeSet newChanges: newSet. newStream setConverterForCode. newStream fileInAnnouncing: 'Loading ' , newName , '...'. Transcript cr; show: 'File ' , aName , ' successfully filed in to change set ' , newName]. aStream close] ensure: [self classChangeSet newChanges: oldChanges]. ^ newSet! ----- Method: Installer>>open (in category 'public interface') ----- open! ----- Method: Installer>>openGL (in category 'package-definitions') ----- openGL "3D library." ^ { self threeDtransform. #krestianstvo -> 'ccse'. 'OpenGL-Pools'. 'OpenGL-Core'. 'OpenGL-NameManager' }! ----- Method: Installer>>osProcess (in category 'package-definitions') ----- osProcess "Launch external executable programs." ^ { #ss -> 'OSProcess'. 'OSProcess' }! ----- Method: Installer>>package (in category 'accessing') ----- package ^ self packages isEmpty ifTrue: [ nil ] ifFalse: [ self packages last ]! ----- Method: Installer>>package: (in category 'accessing') ----- package: anObject self addPackage: anObject.! ----- Method: Installer>>packageAndVersionFrom: (in category 'squeakmap') ----- packageAndVersionFrom: pkg | p | p := ReadStream on: pkg . ^{(p upTo: $(). p upTo: $)} collect: [:s | s withBlanksTrimmed].! ----- Method: Installer>>packages (in category 'accessing') ----- packages ^ packages ifNil: [ packages := OrderedCollection new ]! ----- Method: Installer>>packages: (in category 'accessing') ----- packages: aCollection packages := aCollection! ----- Method: Installer>>packagesMatching: (in category 'searching') ----- packagesMatching: aMatch ^'search type not supported'! ----- Method: Installer>>primMerge: (in category 'private') ----- primMerge: packageName | version | version := (currentRepository includesVersionNamed: packageName) ifTrue: [ currentRepository versionNamed: packageName ] ifFalse: [ currentRepository highestNumberedVersionForPackageNamed: packageName ]. [ version shouldMerge ifTrue: [ version merge ] ifFalse: [ version load ] ] on: MCNoChangesException do: [ : req | req resume ] on: MCMergeResolutionRequest do: [ : request | request merger conflicts isEmpty ifTrue: [ request resume: true ] ifFalse: [ request pass ] ]. version workingCopy repositoryGroup addRepository: currentRepository! ----- Method: Installer>>quietly (in category 'public interface') ----- quietly noiseLevel := #quiet! ----- Method: Installer>>removeChangeSet: (in category 'utils') ----- removeChangeSet: cs (self classChangeSet respondsTo: #removeChangeSet:) ifTrue: [ ^ChangeSet removeChangeSet: cs ]. ^ self classChangeSorter removeChangeSet: cs .! ----- Method: Installer>>reportFor:page:on: (in category 'action report') ----- reportFor: theLine page: thePage on: report [ thePage atEnd ] whileFalse: [ | line | line := thePage nextLine. Installer actionMatch: line reportOn: report ifNoMatch: [ report nextPutAll: line; cr. ]].! ----- Method: Installer>>reportSection:on: (in category 'action report') ----- reportSection: line on: report report isEmpty ifFalse: [ report cr ]. report nextPutAll: '">>>> ' ; nextPutAll: (line copyWithout: $"); nextPut: $"; cr. ! ----- Method: Installer>>search: (in category 'searching') ----- search: aMatch ^'search type not supported'! ----- Method: Installer>>silently (in category 'public interface') ----- silently noiseLevel := #silent! ----- Method: Installer>>squeakRelease (in category 'package-definitions') ----- squeakRelease ^ { self system. '311Deprecated'. '39Deprecated'. '45Deprecated'. 'Nebraska'. 'SmallLand-ColorTheme'. 'ST80'. 'ST80Tools'. 'SystemReporter'. 'Universes'. 'XML-Parser' }! ----- Method: Installer>>squeakSslCore (in category 'package-definitions') ----- squeakSslCore "SSL implementation on top of WebClient. Requires the SqueakSSL VM plugin." ^ { self webClientCore. #ss -> 'SqueakSSL'. 'SqueakSSL-Core' }! ----- Method: Installer>>squeakSslTests (in category 'package-definitions') ----- squeakSslTests "SqueakSSL test package." ^ { self webClientTests. self squeakSslCore. 'SqueakSSL-Tests' }! ----- Method: Installer>>squeaksource (in category 'package-definitions') ----- squeaksource "A source code repository." ^ { #squeak -> 'ss'. 'OSProcess'. 'RFB'. 'SmaCC'. 'DynamicBindings'. 'KomServices'. 'KomHttpServer'. 'Seaside2'. 'Mewa'. 'TinyWiki'. 'SqueakSource' }! ----- Method: Installer>>suppress: (in category 'auto answering') ----- suppress: aMessage messagesToSuppress add: aMessage! ----- Method: Installer>>system (in category 'package-definitions') ----- system "Packages forming the Smalltalk development system." ^ { self core. 'System' }! ----- Method: Installer>>threeDtransform (in category 'package-definitions') ----- threeDtransform ^ { self ffiTests. #ss -> 'CroquetGL'. '3DTransform' }! ----- Method: Installer>>tools (in category 'package-definitions') ----- tools "A minimum core capable of expanding itself." ^ { self core. 'ToolBuilder-Kernel'. 'Tools' }! ----- Method: Installer>>updateStream (in category 'package-definitions') ----- updateStream ^ { self tools. 'UpdateStream' }! ----- Method: Installer>>validChangeSetName: (in category 'url') ----- validChangeSetName: aFileName " dots in the url confuses the changeset loader. I replace them with dashes" (aFileName beginsWith:'http:') ifTrue: [ | asUrl | asUrl := Url absoluteFromText: aFileName. ^String streamContents: [:stream | stream nextPutAll: (asUrl authority copyReplaceAll: '.' with: '-'). asUrl path allButLastDo: [:each | stream nextPutAll: '/'; nextPutAll: (each copyReplaceAll: '.' with: '-') ]. stream nextPutAll: '/'; nextPutAll: asUrl path last ] ]. ^aFileName! ----- Method: Installer>>validate (in category 'logging') ----- validate ValidationBlock value = false ifTrue: [ self error: 'Validation failed' ].! ----- Method: Installer>>versions (in category 'public interface') ----- versions ^ self basicVersions! ----- Method: Installer>>view (in category 'public interface') ----- view self logErrorDuring: [self basicView]! ----- Method: Installer>>view: (in category 'public interface') ----- view: packageNameCollectionOrDetectBlock self package: packageNameCollectionOrDetectBlock. self view! ----- Method: Installer>>view:from: (in category 'mantis') ----- view: aFileName from: stream self log: ' viewing...'. Workspace new contents: (stream contents); openLabel: aFileName. ! ----- Method: Installer>>webClientCore (in category 'package-definitions') ----- webClientCore "Simple, compact, and easy to use HTTP client implementation from Andreas Raab." ^ { #ss3 -> 'WebClient'. 'WebClient-Core' }! ----- Method: Installer>>webClientSsp (in category 'package-definitions') ----- webClientSsp "WebClient supports NTLM/SPNEGO authentication via the Microsoft SSP interface (Windows only)." ^ { self ffiTests. self webClientTests. 'WebClient-SSP' }! ----- Method: Installer>>webClientTests (in category 'package-definitions') ----- webClientTests "Help documentation and tests for Web Client." ^ { self webClientCore. 'WebClient-Tests'. 'WebClient-Help' }! ----- Method: Installer>>withAnswersDo: (in category 'auto answering') ----- withAnswersDo: aBlock (aBlock respondsTo: #valueSuppressingMessages:supplyingAnswers: ) ifTrue: [aBlock valueSuppressingMessages: self messagesToSuppress supplyingAnswers: self answers.] ifFalse: [ aBlock value ] ! Installer subclass: #InstallerFile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerFile>>basicBrowse (in category 'basic interface') ----- basicBrowse self browse: self file from: (FileDirectory readOnlyFileNamed: self file). ! ----- Method: InstallerFile>>basicInstall (in category 'basic interface') ----- basicInstall self install: self file from: (FileDirectory default readOnlyFileNamed: self file) ! ----- Method: InstallerFile>>basicView (in category 'basic interface') ----- basicView self view: self file from: (FileDirectory readOnlyFileNamed: self file). ! ----- Method: InstallerFile>>file (in category 'accessing') ----- file ^ self package! ----- Method: InstallerFile>>file: (in category 'accessing') ----- file: f self package: f! Installer subclass: #InstallerInternetBased instanceVariableNames: 'url pageDataStream markers' classVariableNames: 'Entities' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerInternetBased class>>entities (in category 'accessing') ----- entities ^ Entities ifNil: [ Entities := "enough entities to be going on with" Dictionary new. Entities at: 'lt' put: '<'; at: 'gt' put: '>'; at: 'amp' put: '&'; at: 'star' put: '*'; at: 'quot' put: '"'; at: 'nbsp' put: ' '; yourself ] ! ----- Method: InstallerInternetBased>>classHTTPSocket (in category 'class references') ----- classHTTPSocket ^Smalltalk at: #HTTPSocket ifAbsent: [ self error: 'Network package not present' ]! ----- Method: InstallerInternetBased>>extractFromHtml:option: (in category 'as yet unclassified') ----- extractFromHtml: html option: allOrLast | start stop test in | start := self markersBegin. stop := self markersEnd. test := self markersTest. in := WriteStream with: String new. [ html upToAll: start; atEnd ] whileFalse: [ | chunk | (allOrLast == #last) ifTrue: [ in resetToStart ]. chunk := html upToAll: stop. self isSkipLoadingTestsSet ifTrue: [ chunk := chunk readStream upToAll: test ]. in nextPutAll: chunk. ]. ^self removeHtmlMarkupFrom: in readStream ! ----- Method: InstallerInternetBased>>hasPage (in category 'url') ----- hasPage ^ pageDataStream notNil and: [ pageDataStream size > 0 ] ! ----- Method: InstallerInternetBased>>httpGet: (in category 'utils') ----- httpGet: aUrl | page | page := self classHTTPSocket httpGet: aUrl accept: 'application/octet-stream'. (page respondsTo: #reset) ifFalse: [ self error: 'unable to contact web site' ]. ^ page ! ----- Method: InstallerInternetBased>>isHtmlStream: (in category 'url') ----- isHtmlStream: page "matches '' " | first | first := (page next: 14) asUppercase. ^ (first = '') ! ----- Method: InstallerInternetBased>>markers (in category 'as yet unclassified') ----- markers ^ markers ifNil: [ '..."test ...' ]! ----- Method: InstallerInternetBased>>markers: (in category 'as yet unclassified') ----- markers: anObject markers := anObject! ----- Method: InstallerInternetBased>>markersBegin (in category 'as yet unclassified') ----- markersBegin ^ self markers copyUpTo: $.! ----- Method: InstallerInternetBased>>markersEnd (in category 'as yet unclassified') ----- markersEnd "return the third marker or the second if there are only two" | str a | str := self markers readStream. a := str upToAll: '...'; upToAll: '...'. str atEnd ifTrue: [ ^a ] ifFalse: [ ^str upToEnd ] ! ----- Method: InstallerInternetBased>>markersTest (in category 'as yet unclassified') ----- markersTest ^ self markers readStream upToAll: '...'; upToAll: '...'! ----- Method: InstallerInternetBased>>removeHtmlMarkupFrom: (in category 'as yet unclassified') ----- removeHtmlMarkupFrom: in | out | out := WriteStream on: (String new: 100). [ in atEnd ] whileFalse: [ out nextPutAll: (in upTo: $<). (((in upTo: $>) asLowercase beginsWith: 'br') and: [ (in peek = Character cr) ]) ifTrue: [ in next ]. ]. ^self replaceEntitiesIn: out readStream. ! ----- Method: InstallerInternetBased>>replaceEntitiesIn: (in category 'url') ----- replaceEntitiesIn: in | out | out := WriteStream on: (String new: 100). [ in atEnd ] whileFalse: [ out nextPutAll: ((in upTo: $&) replaceAll: Character lf with: Character cr). in atEnd ifFalse: [ out nextPutAll: (self class entities at: (in upTo: $;) ifAbsent: '?') ]. ]. ^out readStream! ----- Method: InstallerInternetBased>>url (in category 'accessing') ----- url ^url! ----- Method: InstallerInternetBased>>url: (in category 'accessing') ----- url: aUrl url := aUrl! ----- Method: InstallerInternetBased>>urlGet (in category 'url') ----- urlGet ^ self urlGet: self urlToDownload! ----- Method: InstallerInternetBased>>urlGet: (in category 'url') ----- urlGet: aUrl | page | page := HTTPSocket httpGet: aUrl accept: 'application/octet-stream'. (page respondsTo: #reset) ifFalse: [ ^ nil ]. (self isHtmlStream: page) ifTrue: [ page := self extractFromHtml: page option: nil ]. ^ page reset ! ----- Method: InstallerInternetBased>>wasPbwikiSpeedWarning (in category 'url') ----- wasPbwikiSpeedWarning ^ self hasPage and: [pageDataStream contents includesSubString: 'Please slow down a bit' ] ! InstallerInternetBased subclass: #InstallerUrl instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerUrl class>>canReportLine: (in category 'action report') ----- canReportLine: line ^ ((line beginsWith: 'Installer installUrl:') and: [ | ext | ext := (line readStream upToAll: '''.') copyAfterLast: $.. (#( 'cs' 'st' 'mcz' 'sar') includes: ext) not ])! ----- Method: InstallerUrl>>action:reportOn: (in category 'action report') ----- action: line reportOn: report url := line readStream upTo: $' ; upTo: $'. self reportSection: line on: report. (pageDataStream := self urlGet: self urlToDownload) ifNil: [ self error: 'unable to contact host' ]. self reportFor: line page: pageDataStream on: report ! ----- Method: InstallerUrl>>addPackage: (in category 'as yet unclassified') ----- addPackage: aPackageName super addPackage: aPackageName. (self url endsWith: '/') ifFalse: [self url: self url, '/'].! ----- Method: InstallerUrl>>basicBrowse (in category 'basic interface') ----- basicBrowse "(Installer debug url: 'http://installer.pbwiki.com/f/Installer.st') browse.". self browse: self urlToDownload from: self urlThing. ! ----- Method: InstallerUrl>>basicInstall (in category 'basic interface') ----- basicInstall self install: self urlToDownload from: self urlThing. ^ pageDataStream ! ----- Method: InstallerUrl>>basicView (in category 'basic interface') ----- basicView "(Installer debug url: 'http://installer.pbwiki.com/f/Installer.st') view.". self view: self urlToDownload from: self urlThing. ! ----- Method: InstallerUrl>>fileInSource (in category 'accessing') ----- fileInSource " (Installer url: 'http://www.squeaksource.com/Sake/Sake-Core-kph.47.mcz') bootstrap. " | pkg splitPos repo getFileName fileName | useFileIn := true. splitPos := url lastIndexOf: $/. pkg := url copyFrom: splitPos + 1 to: url size. repo := url copyFrom: 1 to: splitPos. getFileName := [ :pkgName | pkgName , ((HTTPSocket httpGet: repo) upToAll: pkgName; upTo: $") ]. fileName := getFileName value: pkg. url := repo,fileName. self install! ----- Method: InstallerUrl>>urlThing (in category 'url') ----- urlThing | retry delay | self logCR: 'retrieving ', self urlToDownload , ' ...'. delay := 0. [retry := false. pageDataStream := self urlGet: self urlToDownload. self wasPbwikiSpeedWarning ifTrue: [ retry := true. delay := delay + 5. self logCR: 'PBWiki speed warning. Retrying in ', delay printString, ' seconds'. (Delay forSeconds: delay) wait ]. retry ] whileTrue. pageDataStream ifNil: [ self error: 'unable to contact host' ]. ^ pageDataStream ! ----- Method: InstallerUrl>>urlToDownload (in category 'url') ----- urlToDownload ^ (self url, (self package ifNil: [ '' ])) asUrl asString. ! InstallerInternetBased subclass: #InstallerWebBased instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! InstallerWebBased subclass: #InstallerMantis instanceVariableNames: 'ma bug desc date array data status' classVariableNames: 'Fixes Status' poolDictionaries: '' category: 'Installer-Core'! !InstallerMantis commentStamp: 'test 1/14/2009 00:11' prior: 0! Search feature is based upon a custom mantis query ceveloped and maintained by Ken Causey Installer mantis bugsAll select: [ :ea | ea status = 'testing' ].! ----- Method: InstallerMantis class>>canReportLine: (in category 'action report') ----- canReportLine: line ^ line beginsWith: 'Installer mantis fixBug:'! ----- Method: InstallerMantis class>>fixesApplied (in category 'accessing') ----- fixesApplied ^ Fixes ifNil: [ Fixes := OrderedCollection new ].! ----- Method: InstallerMantis class>>host: (in category 'instance creation') ----- host: host ^self new ma: host; markers: '"fix begin"..."fix test"..."fix end"'; yourself. ! ----- Method: InstallerMantis class>>initialize (in category 'instance creation') ----- initialize Status := Dictionary new at: '10' put: 'new'; at: '20' put: 'feedback'; at: '30' put: 'acknowledged'; at: '40' put: 'confirmed'; at: '50' put: 'assigned'; at: '60' put: 'pending'; at: '70' put: 'testing'; at: '80' put: 'resolved'; at: '90' put: 'closed'; yourself ! ----- Method: InstallerMantis>>= (in category 'accessing') ----- = other self == other ifTrue: [ ^ true ]. self species = other species ifFalse: [ ^ false ]. ^ array = other array! ----- Method: InstallerMantis>>action:reportOn: (in category 'action report') ----- action: line reportOn: report | param mantis | mantis := Installer mantis. param := line readStream upTo: $: ; upTo: $.. mantis setBug: ((param readStream upTo: $'; atEnd) ifTrue: [ param ] ifFalse: [ param readStream upTo: $'; upTo: $' ]). self reportSection: line on: report. report nextPutAll: (mantis replaceEntitiesIn: mantis markersBegin readStream). self reportFor: line page: mantis maScript on: report. report nextPutAll: (mantis replaceEntitiesIn: mantis markersEnd readStream); cr. ! ----- Method: InstallerMantis>>array (in category 'accessing') ----- array ^ array! ----- Method: InstallerMantis>>browseFile: (in category 'public interface') ----- browseFile: aFileName ^ self browse: aFileName from: (self maThing: aFileName date: nil)! ----- Method: InstallerMantis>>bug (in category 'accessing') ----- bug ^ bug ifNil: [ date := ((self dataAtName: 'Updated') replaceAll: $ with: $T) asDateAndTime. desc := (self dataAtName: 'Summary'). bug := (self dataAtName: 'Id'). self statusInit. ]! ----- Method: InstallerMantis>>bug: (in category 'public interface') ----- bug: aBugNo | page | self setBug: aBugNo. page := self maPage. date := ((self maRead: page field: 'Date Updated') value replaceAll: $ with: $T) asDateAndTime. status := (self maRead: page field: 'Status') value. " Installer mantis bug: 7235 "! ----- Method: InstallerMantis>>bug:browse: (in category 'public interface') ----- bug: aBugNo browse: aFileName self setBug: aBugNo. ^ self browseFile: aFileName! ----- Method: InstallerMantis>>bug:fix: (in category 'public interface') ----- bug: aBugNo fix: aFileName ^ self bug: aBugNo fix: aFileName date: nil! ----- Method: InstallerMantis>>bug:fix:date: (in category 'public interface') ----- bug: aBugNo fix: aFileName date: aDate | | self setBug: aBugNo. self ditchOldChangeSetFor: aFileName. self install: aFileName from: (self maThing: aFileName date: aDate). ^ date! ----- Method: InstallerMantis>>bug:retrieve: (in category 'public interface') ----- bug: aBugNo retrieve: aFileName self setBug: aBugNo. ^ (self maStreamForFile: aFileName) contents! ----- Method: InstallerMantis>>bug:view: (in category 'public interface') ----- bug: aBugNo view: aFileName "Installer mantis bug: 6089 browse: 'TTFSpeedUp-dgd.1.cs'" self setBug: aBugNo. ^ self view: aFileName from: (self maThing: aFileName date: nil)! ----- Method: InstallerMantis>>bugFiles: (in category 'public interface') ----- bugFiles: aBugNo "provide a list of files associated with the bug in id order" " Installer mantis bugFiles: 6660. " self setBug: aBugNo; files! ----- Method: InstallerMantis>>bugFilesView: (in category 'public interface') ----- bugFilesView: aBugNo "provide a list of files associated with the bug in id order" " Installer mantis bugFiles: 6660. " self setBug: aBugNo; viewFiles! ----- Method: InstallerMantis>>bugScript: (in category 'public interface') ----- bugScript: aBugNo ^ (self setBug: aBugNo) script ! ----- Method: InstallerMantis>>bugsAll (in category 'action report') ----- bugsAll ^ array ifNil: [ array := ( self bugsSqueak , (self dataGetFrom: '/installer_export.php') ) asSet asSortedCollection: [ :a :b | a date > b date ] ]. " Installer mantis bugsAll " ! ----- Method: InstallerMantis>>bugsClosed (in category 'search') ----- bugsClosed ^ array ifNil: [ array := self dataGetFrom: '/installer_export.php?closed' ]! ----- Method: InstallerMantis>>bugsRelease: (in category 'search') ----- bugsRelease: version ^self bugsAll select: [ :ea | (ea status = 'resolved') and: [ ea fixedIn = version ]]! ----- Method: InstallerMantis>>bugsSqueak (in category 'search') ----- bugsSqueak ^ array ifNil: [ array := self dataGetFrom: '/installer_export.php?project=Squeak' ] " Installer mantis bugsSqueak. Installer mantis bugsAll. Installer mantis bugsClosed. "! ----- Method: InstallerMantis>>bugsTesting: (in category 'search') ----- bugsTesting: version ^self bugsAll select: [ :ea | ea status = 'testing' and: [ ea fixedIn = version ]]! ----- Method: InstallerMantis>>category (in category 'search') ----- category ^ self dataAtName: 'Category' " s bugs collect: [ :ea | ea category ] "! ----- Method: InstallerMantis>>dataAtName: (in category 'search') ----- dataAtName: key ^ array at: (self dataNames indexOf: key)! ----- Method: InstallerMantis>>dataAtName:put: (in category 'search') ----- dataAtName: key put: v ^ array at: (self dataNames indexOf: key) put: v! ----- Method: InstallerMantis>>dataClosed (in category 'search') ----- dataClosed ^ array ifNil: [ array := self dataGetFrom: '/installer_export.php?closed' ]! ----- Method: InstallerMantis>>dataGetFrom: (in category 'public interface') ----- dataGetFrom: aPath | rs line first col row out | rs := HTTPSocket httpGet: ma, aPath. rs isString ifTrue: [ ^ ProtocolClientError signal: 'notFound' ]. first := true. out := OrderedCollection new. [ rs atEnd ] whileFalse: [ line := rs nextLine readStream. col := 1. row := Array new: 9. [ (line atEnd or: [ col > 9 ]) ] whileFalse: [ row at: col put: (line upTo: $|). col := col + 1 ]. rs next. [ out add: (self class new in: self row: row) ] ifError: [] ]. ^ out " self reset. self getBugsList "! ----- Method: InstallerMantis>>dataNames (in category 'public interface') ----- dataNames ^ #(Id Project Category Assigned Updated Status Severity FixedIn Summary)! ----- Method: InstallerMantis>>date (in category 'accessing') ----- date ^ date ! ----- Method: InstallerMantis>>date: (in category 'accessing') ----- date: anObject date := anObject ifNotNil: [anObject asDate ]! ----- Method: InstallerMantis>>desc (in category 'accessing') ----- desc ^ desc! ----- Method: InstallerMantis>>desc: (in category 'accessing') ----- desc: anObject desc := anObject! ----- Method: InstallerMantis>>ensureFix (in category 'public interface') ----- ensureFix | fixesAppliedNumbers | fixesAppliedNumbers := self fixesApplied collect: [ :fixDesc | fixDesc asInteger ]. (fixesAppliedNumbers includes: bug) ifFalse: [ self fixBug ]! ----- Method: InstallerMantis>>ensureFix: (in category 'public interface') ----- ensureFix: aBugNo ^self ensureFix: aBugNo date: nil! ----- Method: InstallerMantis>>ensureFix:date: (in category 'public interface') ----- ensureFix: aBugNo date: aDate self setBug: aBugNo. self date: aDate. self ensureFix.! ----- Method: InstallerMantis>>ensureFixes: (in category 'public interface') ----- ensureFixes: aBugNos aBugNos do: [ :bugNo | self ensureFix: bugNo ].! ----- Method: InstallerMantis>>files (in category 'public interface') ----- files "provide a list of files associated with the bug in id order" " Installer mantis bugFiles: 6660. " ^ (self maFiles associations asSortedCollection: [ :a :b | a value asInteger < b value asInteger ]) collect: [ :a | a key ]! ----- Method: InstallerMantis>>fixBug (in category 'public interface') ----- fixBug self install: self maUrl from: self maScript. self maCheckDateAgainst: date. self fixesAppliedNumbers in: [ :fixed | (fixed isEmpty or: [ (fixed includes: bug asInteger) not]) ifTrue: [ self fixesApplied add: (bug asString, ' ', desc) ]]. ! ----- Method: InstallerMantis>>fixBug: (in category 'public interface') ----- fixBug: aBugNo ^ self fixBug: aBugNo date: nil. ! ----- Method: InstallerMantis>>fixBug:date: (in category 'public interface') ----- fixBug: aBugNo date: aDate self setBug: aBugNo. self date: aDate. self fixBug. ! ----- Method: InstallerMantis>>fixedIn (in category 'search') ----- fixedIn ^ self dataAtName: 'FixedIn' ! ----- Method: InstallerMantis>>fixesApplied (in category 'public interface') ----- fixesApplied ^ Fixes ifNil: [ Fixes := OrderedCollection new ].! ----- Method: InstallerMantis>>fixesAppliedNumbers (in category 'public interface') ----- fixesAppliedNumbers ^ self fixesApplied collect: [ :fixDesc | fixDesc asInteger ]. ! ----- Method: InstallerMantis>>getView (in category 'accessing') ----- getView "Installer mantis viewBug: 5639." | page text | page := self maPage. text := String streamContents: [ :str | #('Bug ID' 'Category' 'Severity' 'Reproducibility' 'Date Submitted' 'Date Updated' 'Reporter' 'View Status' 'Handler' 'Priority' 'Resolution' 'Status' 'Product Version' 'Summary' 'Description' 'Additional Information' ) do: [ :field | | f | f := self maRead: page field: field. str nextPutAll: f key; nextPutAll: ': '; nextPutAll: f value; cr. ]. str nextPutAll: 'Notes: '; cr. (self maReadNotes: page) do: [ :note | str nextPutAll: note; cr; cr ]. str nextPutAll: 'Files: '; nextPutAll: self maFiles keys asArray printString. ]. ^ text ! ----- Method: InstallerMantis>>hash (in category 'accessing') ----- hash ^ array hash! ----- Method: InstallerMantis>>in:row: (in category 'public interface') ----- in: parent row: dataRow self ma: parent ma. self markers: parent markers. self setArray: dataRow.! ----- Method: InstallerMantis>>justFixBug: (in category 'public interface') ----- justFixBug: aBugNo ^self class skipLoadingTests: true during: [ self fixBug: aBugNo date: nil ]! ----- Method: InstallerMantis>>justFixBug:date: (in category 'public interface') ----- justFixBug: aBugNo date: d ^self class skipLoadingTests: true during: [ self fixBug: aBugNo date: d ]! ----- Method: InstallerMantis>>ma (in category 'accessing') ----- ma ^ ma! ----- Method: InstallerMantis>>ma: (in category 'accessing') ----- ma: aUrl ma := aUrl last = $/ ifTrue: [ aUrl ] ifFalse: [ aUrl, '/' ]! ----- Method: InstallerMantis>>maCheckDateAgainst: (in category 'utils') ----- maCheckDateAgainst: okDate (okDate notNil and: [date < okDate asDate ]) ifTrue: [ self notify: 'bug ', self bug asString, ' updated on ', date printString ]. ! ----- Method: InstallerMantis>>maFiles (in category 'mantis') ----- maFiles | file files bugPage id | files := Dictionary new. bugPage := self maPage. [ id := bugPage upToAll: 'href="file_download.php?file_id='; upTo: $&. file := bugPage upToAll: 'amp;type=bug"' ; upTo: $<. ((file size > 1) and: [file first = $>]) ifTrue: [ files at: file copyWithoutFirst put: id ]. id notEmpty ] whileTrue. ^files ! ----- Method: InstallerMantis>>maPage (in category 'mantis') ----- maPage " self mantis bug: 5251." | page | page := self httpGet: self maUrl. date := ((self maRead: page field: 'Date Updated') value copyUpTo: $ ). date isEmpty ifTrue: [ ^self error: bug asString, ' not found' ]. date := date asDate. ^page reset! ----- Method: InstallerMantis>>maRead:field: (in category 'mantis') ----- maRead: page field: fieldKey | value | value := page upToAll: ('!!-- ', fieldKey, ' -->'); upToAll: '; upToAll: ''. page upTo: $<. page peek = $t ifTrue: [ value := page upToAll: 'td'; upTo: $>; upToAll: '' ]. ^Association key: fieldKey value: (self removeHtmlMarkupFrom: value withBlanksTrimmed readStream) contents! ----- Method: InstallerMantis>>maReadNotes: (in category 'mantis') ----- maReadNotes: page | notes note | notes := OrderedCollection new. [ page upToAll: 'tr class="bugnote"'; upTo: $>. page atEnd ] whileFalse: [ note := (self removeHtmlMarkupFrom: (page upToAll: '') readStream) contents. note := note withBlanksCondensed. note replaceAll: Character lf with: Character cr. notes add: note ]. ^notes! ----- Method: InstallerMantis>>maScript (in category 'mantis') ----- maScript ^self extractFromHtml: self maPage option: #last ! ----- Method: InstallerMantis>>maStreamForFile: (in category 'mantis') ----- maStreamForFile: aFileName | fileId | fileId := self maFiles at: aFileName ifAbsent: [ self error: aFileName, ' not found' ]. ^ self httpGet: (self ma, 'file_download.php?file_id=' , fileId , '&type=bug'). ! ----- Method: InstallerMantis>>maThing:date: (in category 'mantis') ----- maThing: aFileName date: aDate self logCR: 'obtaining ', aFileName, '...'. pageDataStream := self maStreamForFile: aFileName. self maCheckDateAgainst: aDate. ^ pageDataStream ! ----- Method: InstallerMantis>>maUrl (in category 'mantis') ----- maUrl ^ url := self ma, 'view.php?id=', bug asString ! ----- Method: InstallerMantis>>maUrlFor: (in category 'mantis') ----- maUrlFor: maBugNo ^ url := self ma, 'view.php?id=', maBugNo asString ! ----- Method: InstallerMantis>>printOn: (in category 'accessing') ----- printOn: stream super printOn: stream. (array ifNil: [ ^ self ]) printOn: stream.! ----- Method: InstallerMantis>>project (in category 'search') ----- project ^ self dataAtName: 'Project' ! ----- Method: InstallerMantis>>report (in category 'public interface') ----- report "Installer mantis viewBug: 5639." | page text | page := self maPage. text := String streamContents: [ :str | #('Bug ID' 'Category' 'Severity' 'Reproducibility' 'Date Submitted' 'Date Updated' 'Reporter' 'View Status' 'Handler' 'Priority' 'Resolution' 'Status' 'Product Version' 'Summary' 'Description' 'Additional Information' ) do: [ :field | | f | f := self maRead: page field: field. str nextPutAll: f key; nextPutAll: ': '; nextPutAll: f value; cr. ]. str nextPutAll: 'Notes: '; cr. (self maReadNotes: page) do: [ :note | str nextPutAll: note; cr; cr ]. str nextPutAll: 'Files: '; nextPutAll: self maFiles keys asArray printString. ]. ^ text ! ----- Method: InstallerMantis>>script (in category 'public interface') ----- script ^ self maScript contents. ! ----- Method: InstallerMantis>>selectCategoryCollections (in category 'public interface') ----- selectCategoryCollections ^ self select: [ :ea | ea category = 'Collections' ]! ----- Method: InstallerMantis>>setArray: (in category 'public interface') ----- setArray: dataRow (array := dataRow) ifNotNil: [ self bug ].! ----- Method: InstallerMantis>>setBug: (in category 'mantis') ----- setBug: stringOrNumber | newBug | (newBug := stringOrNumber asInteger) = bug ifTrue: [ ^ self ]. self logCR: 'Installer accessing bug: ' , stringOrNumber asString. bug := newBug. stringOrNumber = bug ifTrue: [ desc := ''. ^ self ]. desc := stringOrNumber withoutLeadingDigits ! ----- Method: InstallerMantis>>status (in category 'accessing') ----- status ^ status! ----- Method: InstallerMantis>>statusInit (in category 'accessing') ----- statusInit status ifNil: [ status := Status at: (self dataAtName: 'Status'). self dataAtName:'Status' put: status. ]. ! ----- Method: InstallerMantis>>summary (in category 'search') ----- summary ^ self dataAtName: 'Summary'! ----- Method: InstallerMantis>>validChangeSetName: (in category 'action report') ----- validChangeSetName: aFileName | csn prefix | csn := super validChangeSetName: aFileName. prefix := 'M' , self bug asInteger asString. csn := csn replaceAll: ('-', prefix) with: ''. csn := csn replaceAll: (prefix,'-') with: ''. csn := csn replaceAll: prefix with: ''. ^ prefix, '-', csn ! ----- Method: InstallerMantis>>view (in category 'public interface') ----- view ^ Workspace new contents: self report; openLabel: ('Mantis ', bug printString). ! ----- Method: InstallerMantis>>viewBug: (in category 'public interface') ----- viewBug: aBugNo self setBug: aBugNo; view! ----- Method: InstallerMantis>>viewFile: (in category 'public interface') ----- viewFile: aFileName "Installer mantis bug: 6089 browse: 'TTFSpeedUp-dgd.1.cs'" ^ self view: aFileName from: (self maThing: aFileName date: nil)! ----- Method: InstallerMantis>>viewFiles (in category 'public interface') ----- viewFiles ^ self files do: [ :ea | self viewFile: ea ].! InstallerWebBased subclass: #InstallerWeb instanceVariableNames: '' classVariableNames: 'WebSearchPath' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerWeb class>>canReportLine: (in category 'action report') ----- canReportLine: line ^ ((line beginsWith: 'Installer install:') | (line beginsWith: 'Installer do:'))! ----- Method: InstallerWeb class>>initialize (in category 'instanciation') ----- initialize WebSearchPath := nil! ----- Method: InstallerWeb class>>install: (in category 'compatability') ----- install: webPageName "This keeps the syntax Installer web install: working" ^ self new install: webPageName! ----- Method: InstallerWeb class>>searchPath (in category 'accessing') ----- searchPath "a search path item, has the following format. prefix*suffix" ^ WebSearchPath ifNil: [ WebSearchPath := OrderedCollection new ].! ----- Method: InstallerWeb>>action:reportOn: (in category 'action report') ----- action: line reportOn: report self package: (line readStream upTo: $' ; upTo: $'). self reportSection: line on: report. url := self urlToDownload. self reportFor: line page: pageDataStream on: report ! ----- Method: InstallerWeb>>basicBrowse (in category 'basic interface') ----- basicBrowse self thing size > 0 ifTrue: [ self browse: url from: pageDataStream ] ifFalse: [ self logCR: 'NO DATA ',url,' was empty' ]. ! ----- Method: InstallerWeb>>basicInstall (in category 'basic interface') ----- basicInstall self thing size > 0 ifTrue: [ self install: url from: pageDataStream ] ifFalse: [ url ifNil: [ ^ self logCR: self package, ' not found on webSearchPath' ]. self logCR: '...',url,' was empty' ]. ! ----- Method: InstallerWeb>>basicView (in category 'basic interface') ----- basicView self thing size > 0 ifTrue: [ self view: url from: pageDataStream ] ifFalse: [ self logCR: 'NO DATA ',url,' was empty' ]. ! ----- Method: InstallerWeb>>thing (in category 'web install') ----- thing self logCR: 'searching for web package ''', self package, ''''. url := self urlToDownload. url ifNil: [ self logCR: 'page ', self package, ' not found on path' ] ifNotNil: [ self logCR: 'found ', url, ' ...'. ]. ^ pageDataStream! ----- Method: InstallerWeb>>urlToDownload (in category 'web install') ----- urlToDownload "while we look for a url which returns what we are looking for, we get the data anyway" | delay | delay := 0. self class webSearchPath do: [ :pathSpec | | potentialUrl readPathSpec retry | readPathSpec := pathSpec value readStream. potentialUrl := (readPathSpec upTo: $*), self package, (readPathSpec upToEnd ifNil: [ '' ]). [retry := false. pageDataStream := self urlGet: potentialUrl. self wasPbwikiSpeedWarning ifTrue: [ retry := true. delay := delay + 5. self logCR: 'PBWiki speed warning. Retrying in ', delay printString, ' seconds'. (Delay forSeconds: delay) wait] ifFalse: [ self hasPage ifTrue: [ pageDataStream reset. ^ potentialUrl ] ]. retry ] whileTrue ]. ^nil ! InstallerWebBased subclass: #InstallerWebSqueakMap instanceVariableNames: 'wsm' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerWebSqueakMap>>basicAvailablePackages (in category 'websqueakmap') ----- basicAvailablePackages | html id name pkgs | pkgs := Dictionary new. html := self httpGet: (self wsm, 'packagesbyname'). [ id := html upToAll: '/package/'; upToAll: '">'. name := html upTo: $<. (id notEmpty and: [ name notEmpty ])] whileTrue: [ pkgs at: name put: id ]. ^ pkgs ! ----- Method: InstallerWebSqueakMap>>basicInstall (in category 'basic interface') ----- basicInstall | it | it := self wsmThing. self install: it from: it asUrl retrieveContents contentStream. ! ----- Method: InstallerWebSqueakMap>>basicVersions (in category 'basic interface') ----- basicVersions | pkgAndVersion packageId packageName packageVersion versions | pkgAndVersion := self packageAndVersionFrom: self package . packageName := pkgAndVersion first. packageVersion := pkgAndVersion last. packageVersion isEmpty ifTrue: [ packageVersion := #latest ]. packageId := self availablePackages at: packageName. versions := (self wsmReleasesFor: packageId) keys asSet. versions remove: #latest. ^ versions collect: [ :version | self copy package: (packageName,'(', version ,')'); yourself ]. ! ----- Method: InstallerWebSqueakMap>>basicView (in category 'basic interface') ----- basicView | it | it := self wsmThing. self view: it from: (self httpGet: it). ! ----- Method: InstallerWebSqueakMap>>packagesMatching: (in category 'searching') ----- packagesMatching: aMatch ^ (self availablePackages select: [ :p | ( aMatch) match: p ]) collect: [ :p | self copy package: p ; yourself ]! ----- Method: InstallerWebSqueakMap>>wsm (in category 'websqueakmap') ----- wsm ^ wsm! ----- Method: InstallerWebSqueakMap>>wsm: (in category 'websqueakmap') ----- wsm: aUrl wsm := aUrl last = $/ ifTrue: [ aUrl ] ifFalse: [ aUrl, '/' ]! ----- Method: InstallerWebSqueakMap>>wsmDownloadUrl (in category 'websqueakmap') ----- wsmDownloadUrl | pkgAndVersion packageId packageName packageVersion releaseAutoVersion downloadPage | pkgAndVersion := self packageAndVersionFrom: self package. packageName := pkgAndVersion first. packageVersion := pkgAndVersion last. packageVersion isEmpty ifTrue: [ packageVersion := #latest ]. packageId := self availablePackages at: packageName. releaseAutoVersion := (self wsmReleasesFor: packageId) at: packageVersion. downloadPage := self httpGet: (self wsm,'packagebyname/', packageName,'/autoversion/', releaseAutoVersion,'/downloadurl') asUrl asString. ^ downloadPage contents ! ----- Method: InstallerWebSqueakMap>>wsmReleasesFor: (in category 'websqueakmap') ----- wsmReleasesFor: packageId | html autoVersion version releases | releases := Dictionary new. html := self httpGet: (self wsm, '/package/', packageId ). [releases at: #latest put: autoVersion. autoVersion := html upToAll: '/autoversion/'; upTo: $". version := html upTo: $-; upTo: $<. (autoVersion notEmpty and: [version notEmpty ])] whileTrue: [ releases at: version put: autoVersion ]. ^ releases ! ----- Method: InstallerWebSqueakMap>>wsmThing (in category 'websqueakmap') ----- wsmThing | downloadUrl | self logCR: 'finding ', self package, ' from websqueakmap(', self wsm, ') ...'. downloadUrl := self wsmDownloadUrl. self logCR: 'found at ', downloadUrl asString, ' ...'. ^ downloadUrl ! Installer subclass: #InstallerMonticello instanceVariableNames: 'mc root project' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerMonticello>>basicAvailablePackages (in category 'basic interface') ----- basicAvailablePackages ^ self mc allPackageNames! ----- Method: InstallerMonticello>>basicBrowse (in category 'basic interface') ----- basicBrowse "Installer ss project: 'Installer'; browse: 'Installer-Core'." | it | it := self mcThing. (it class includesSelector: #browse) ifTrue: [ ^ it browse ]. (it instVarNamed: 'versions') do: [ :each | each browse ].! ----- Method: InstallerMonticello>>basicInstall (in category 'basic interface') ----- basicInstall self withAnswersDo: [ self mcThing load ]. self logCR: 'loaded'. ! ----- Method: InstallerMonticello>>basicVersions (in category 'basic interface') ----- basicVersions ^ (self availablePackages select: [ :p | ( self package,'-*.mcz' ) match: p ]) collect: [ :p | self copy package: p ; yourself ]. ! ----- Method: InstallerMonticello>>basicView (in category 'basic interface') ----- basicView "Installer ss project: 'Installer'; view: 'Installer-Core'. " | it | packages isEmptyOrNil ifTrue: [ self mc morphicOpen: nil ]. it := self mcThing. (it respondsTo: #open) ifTrue: [ ^ it open ]. "in case an old mc doesnt have #open" (it instVarNamed: 'versions') do: [ :each | each open ]. ! ----- Method: InstallerMonticello>>cache (in category 'instance creation') ----- cache mc := self classMCCacheRepository default. root := mc directory localName ! ----- Method: InstallerMonticello>>classMCCacheRepository (in category 'class references') ----- classMCCacheRepository ^Smalltalk at: #MCCacheRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCDirectoryRepository (in category 'class references') ----- classMCDirectoryRepository ^Smalltalk at: #MCDirectoryRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCFtpRepository (in category 'class references') ----- classMCFtpRepository ^Smalltalk at: #MCFtpRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCGOODSRepository (in category 'class references') ----- classMCGOODSRepository ^Smalltalk at: #MCGOODSRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCHttpRepository (in category 'class references') ----- classMCHttpRepository ^Smalltalk at: #MCHttpRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCMagmaRepository (in category 'class references') ----- classMCMagmaRepository ^Smalltalk at: #MCMagmaRepository ifAbsent: [ self error: 'Magma not present' ] ! ----- Method: InstallerMonticello>>classMCSmtpRepository (in category 'class references') ----- classMCSmtpRepository ^Smalltalk at: #MCSmtpRepository ifAbsent: [ self error: 'Monticello not present' ] ! ----- Method: InstallerMonticello>>classMCVersionLoader (in category 'class references') ----- classMCVersionLoader ^Smalltalk at: #MCVersionLoader ifAbsent: [ self error: 'Monticello not present' ]! ----- Method: InstallerMonticello>>directory: (in category 'instance creation') ----- directory: dir | directory | directory := dir isString ifTrue: [ FileDirectory on: (FileDirectory default fullNameFor: dir) ] ifFalse: [ dir ]. mc := self classMCDirectoryRepository new directory: directory; yourself. root := dir ! ----- Method: InstallerMonticello>>fromUrl: (in category 'accessing') ----- fromUrl: aUrl | url path | url := aUrl asUrl. self http: url authority. path := url path. path size = 2 ifTrue: [ self project: path first. path removeFirst. ]. path size = 1 ifTrue: [ self package: path first ].! ----- Method: InstallerMonticello>>ftp:directory:user:password: (in category 'instance creation') ----- ftp: host directory: dir user: name password: secret "Installer mc ftp: 'mc.gjallar.se' directory: '' user: 'gjallar' password: secret." mc := self classMCFtpRepository host: host directory: dir user: name password: secret. root := dir. ! ----- Method: InstallerMonticello>>goods:port: (in category 'instance creation') ----- goods: host port: aport mc := (self classMCGOODSRepository new) host: host port: aport; yourself ! ----- Method: InstallerMonticello>>http: (in category 'instance creation') ----- http: aUrl self http: aUrl user: '' password: '' ! ----- Method: InstallerMonticello>>http:user:password: (in category 'instance creation') ----- http: aUrl user: name password: secret | url | url := (aUrl includesSubString: '://') ifTrue: [aUrl] ifFalse: ['http://', aUrl]. mc := self classMCHttpRepository location: url user: name password: secret. root := mc locationWithTrailingSlash ! ----- Method: InstallerMonticello>>initialize (in category 'public interface') ----- initialize super initialize. mc := MCRepositoryGroup default! ----- Method: InstallerMonticello>>latest (in category 'accessing') ----- latest | newPackage | newPackage := self package copyUpToLast: $-. self packages removeLast. self package: newPackage " Installer mc fromUrl: 'http://www.squeaksource.com/Installer/Installer-Core-kph.100.mcz'. "! ----- Method: InstallerMonticello>>latestFromUsers: (in category 'accessing') ----- latestFromUsers: list | newPackage | newPackage := self package copyUpToLast: $-. self packages removeLast. self package: (list collect: [ :ea | newPackage, '-', ea ])! ----- Method: InstallerMonticello>>magma:port: (in category 'instance creation') ----- magma: host port: aport mc := (self classMCMagmaRepository new) host: host port: aport; yourself ! ----- Method: InstallerMonticello>>mc (in category 'accessing') ----- mc ^ mc! ----- Method: InstallerMonticello>>mc: (in category 'accessing') ----- mc: aRepo mc := aRepo! ----- Method: InstallerMonticello>>mcDetectFileBlock: (in category 'monticello') ----- mcDetectFileBlock: pkg pkg isString ifTrue: [ ^ [ :aMCVersionName | (pkg beginsWith: aMCVersionName packageAndBranchName) and: [aMCVersionName beginsWith: pkg ] ] ]. (pkg isKindOf: Array) ifTrue: [ ^ [ :aMCVersionName | pkg anySatisfy: [ :item | (item beginsWith: aMCVersionName packageAndBranchName) and: [aMCVersionName beginsWith: item ] ] ] ]. pkg isBlock ifTrue: [ ^ pkg ]. ! ----- Method: InstallerMonticello>>mcSortFileBlock (in category 'monticello') ----- mcSortFileBlock ^ [:a :b | [(a findBetweenSubStrs: #($.)) allButLast last asInteger > (b findBetweenSubStrs: #($.)) allButLast last asInteger] on: Error do: [:ex | false]].! ----- Method: InstallerMonticello>>mcThing (in category 'monticello') ----- mcThing | loader | loader := self classMCVersionLoader new. "several attempts to read files - repository readableFileNames sometimes fails" self packages do: [:pkg | | versionNames fileToLoad version | versionNames := mc versionNamesForPackageNamed: (pkg asMCVersionName versionNumber = 0 ifTrue: [ "Just a package name specified, use it whole." pkg ] ifFalse: [pkg asMCVersionName packageName]). fileToLoad := (versionNames sorted: self mcSortFileBlock) detect: (self mcDetectFileBlock: pkg) ifNone: [ nil ]. fileToLoad ifNotNil: [version := mc versionNamed: fileToLoad. (version isKindOf: MCConfiguration) ifTrue: [^ version] ifFalse: [self normalizedRepositories do: [:repo | MCRepositoryGroup default addRepository: repo]. self normalizedRepositories do: [:repo | version workingCopy repositoryGroup addRepository: repo]. loader addVersion: version]. self logCR: ' found ' , version fileName , '...']]. ^ loader! ----- Method: InstallerMonticello>>mcUrl (in category 'monticello') ----- mcUrl ^ self mc description ! ----- Method: InstallerMonticello>>normalizedRepositories (in category 'monticello') ----- normalizedRepositories "Find an existing instance of any active repository so that we use whatever name and password the user usually uses. If not found, answer a copy" ^ mc repositories replace: [:repo | (MCRepositoryGroup default repositories includes: repo) ifTrue: [repo] ifFalse: [repo copy]]! ----- Method: InstallerMonticello>>open (in category 'public interface') ----- open self mc morphicOpen: nil! ----- Method: InstallerMonticello>>packagesMatching: (in category 'searching') ----- packagesMatching: aMatch ^ (self availablePackages select: [:p | ( aMatch , '.mcz' ) match: p]) collect: [:p | self copy package: p ; yourself]! ----- Method: InstallerMonticello>>project (in category 'accessing') ----- project ^ project! ----- Method: InstallerMonticello>>project: (in category 'accessing') ----- project: name project := name. packages := nil. (mc respondsTo: #location:) ifTrue:[ mc := mc copy location: root , name ]. (mc respondsTo: #directory:) ifTrue: [ mc := mc copy directory: root / name ]. ^self copy.! ----- Method: InstallerMonticello>>unload (in category 'public interface') ----- unload (MCWorkingCopy allManagers select: [ : each | self package match: each package name ]) do: [ : each | self logCR: 'Unloading ' , each package name. each unload. MCMcmUpdater disableUpdatesOfPackage: each package name ]. self unloadCleanUp! ----- Method: InstallerMonticello>>unload: (in category 'public interface') ----- unload: match self addPackage: match. self unload.! ----- Method: InstallerMonticello>>unloadCleanUp (in category 'public interface') ----- unloadCleanUp SystemOrganization removeEmptyCategories. "Until Mantis 5718 is addressed" Smalltalk at: #PackagePaneBrowser ifPresent: [ :ppbClass | ppbClass allInstancesDo: [ :ppb | ppb updatePackages ] ]. Smalltalk at: #Browser ifPresent: [ :bClass | bClass allInstancesDo: [ :b | b updateSystemCategories ] ]. Smalltalk fixObsoleteReferences.! Installer subclass: #InstallerSake instanceVariableNames: 'sake' classVariableNames: 'Sake' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerSake class>>classPackages (in category 'accessing system') ----- classPackages ^Smalltalk at: #Packages ifAbsent: [ self error: 'Sake Packages code not present' ]! ----- Method: InstallerSake class>>sake (in category 'accessing') ----- sake ^ Sake ifNil: [ self classPackages current ]! ----- Method: InstallerSake class>>sake: (in category 'accessing') ----- sake: aClass Sake := aClass! ----- Method: InstallerSake>>basicInstall (in category 'basic interface') ----- basicInstall self withAnswersDo: [ (self packages collect: [ :packageName | sake named: packageName ]) asTask run ]. ! ----- Method: InstallerSake>>sake (in category 'websqueakmap') ----- sake ^ sake ! ----- Method: InstallerSake>>sake: (in category 'websqueakmap') ----- sake: aSakePackagesClass sake := aSakePackagesClass! Installer subclass: #InstallerSqueakMap instanceVariableNames: 'sm' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerSqueakMap>>basicAvailablePackages (in category 'basic interface') ----- basicAvailablePackages ^self classSMSqueakMap default packagesByName! ----- Method: InstallerSqueakMap>>basicBrowse (in category 'basic interface') ----- basicBrowse self smThing explore! ----- Method: InstallerSqueakMap>>basicInstall (in category 'basic interface') ----- basicInstall self log: ' installing '. self withAnswersDo: [ self smThing install ]. self log: ' done'. ! ----- Method: InstallerSqueakMap>>basicVersions (in category 'basic interface') ----- basicVersions ^ (self smReleasesForPackage: self package) collect: [ :v | self copy package: (v package name,'(',v version,')'); yourself. ] ! ----- Method: InstallerSqueakMap>>basicView (in category 'basic interface') ----- basicView self smThing explore! ----- Method: InstallerSqueakMap>>classSMLoader (in category 'class references') ----- classSMLoader ^Smalltalk at: #SMLoader ifAbsent: [ self error: 'SqueakMap Loader not present' ]! ----- Method: InstallerSqueakMap>>classSMSqueakMap (in category 'class references') ----- classSMSqueakMap ^Smalltalk at: #SMSqueakMap ifAbsent: [ self error: 'SqueakMap not present' ]! ----- Method: InstallerSqueakMap>>open (in category 'public interface') ----- open self classSMLoader open! ----- Method: InstallerSqueakMap>>packagesMatching: (in category 'searching') ----- packagesMatching: aMatch ^ (self availablePackages select: [ :p | aMatch match: p name ]) collect: [ :p | self copy package: p name; yourself ]! ----- Method: InstallerSqueakMap>>search: (in category 'searching') ----- search: aMatch | results | results := Set new. self availablePackages do: [ :pkg | ({ 'name:',pkg name. 'summary:', pkg summary. 'description:', pkg description. 'author:', pkg author. } anySatisfy: [ :field | aMatch match: field ]) ifTrue: [ results add: (self copy package: pkg name) ]. ]. ^results ! ----- Method: InstallerSqueakMap>>sm (in category 'accessing') ----- sm ^ sm ifNil: [ false ]! ----- Method: InstallerSqueakMap>>sm: (in category 'accessing') ----- sm: anObject sm := anObject! ----- Method: InstallerSqueakMap>>smPackageAndVersion (in category 'squeakmap') ----- smPackageAndVersion ^ self packageAndVersionFrom: self package.! ----- Method: InstallerSqueakMap>>smReleasesForPackage: (in category 'squeakmap') ----- smReleasesForPackage: name ^(self classSMSqueakMap default packageWithName: name) releases! ----- Method: InstallerSqueakMap>>smThing (in category 'squeakmap') ----- smThing | pkgAndVersion releases release | pkgAndVersion := self packageAndVersionFrom: self package. self logCR: 'retrieving ', self package, ' from SqueakMap...'. releases := self smReleasesForPackage: pkgAndVersion first. release := pkgAndVersion last isEmpty ifTrue: [ releases last ] ifFalse:[ releases detect: [ :rel | rel version = pkgAndVersion last ] ]. ^ release ! ----- Method: InstallerSqueakMap>>update (in category 'squeakmap') ----- update "Updates the local map for SqueakMap, upgrading SqueakMap to the latest version if necessary. When SqueakMap is old and needs to be upgraded, it does four things that mostly make sense in the interactive world SM was built for, but are totally evil here in the world of automatic scripting: 1. It asks the user if she wants to upgrade, in the form of a pop-up (see SMSqueakMap >> #checkVersion:). 2. It terminates its own process. 3. It creates a new UI process. (see the last line of the SqueakMap upgrade file-in: ''Project spawnNewProcessAndTerminateOld: true'', from http://map.squeak.org/accountbyid/9bdedc18-1525-44a6-9b79-db5d4a87f6f8/files/SqueakMap8.st 4. It opens a SqueakMap window We work around these three problems seperately: 1. We use #answer:with: and #withAnswersDo: to automatically answer ''Yes'' when asked if we want to upgrade 2. We don't want this process to be terminated, so we run the update in a forked process and wait for it to finish, using #fork, #ensure:, and a Semaphore 3. We keep track of the UI process before updating, and if it changes, we terminate the new UI process and reinstall the old one using Project >> #resumeProcess: 4. We don't bother with the newly opened window. The other three problems are much worse. We do all this in a new process, since it is not unlikely that this method is executing in the UI process" | oldUIProcess doneSema | self answer: 'You need to upgrade the SqueakMap package' with: true. oldUIProcess := Project uiProcess. doneSema := Semaphore new. [[self withAnswersDo: [self classSMSqueakMap default loadUpdates]] ensure: [ | newUIProcess | newUIProcess := Project uiProcess. (oldUIProcess ~~ newUIProcess and: [oldUIProcess notNil and: [oldUIProcess isTerminated not]]) ifTrue: [ newUIProcess ifNotNil: [newUIProcess terminate]. oldUIProcess suspend. Project resumeProcess: oldUIProcess.]. doneSema signal]] fork. doneSema wait! Installer subclass: #InstallerUniverse instanceVariableNames: 'universe' classVariableNames: 'LastUniUpdate' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerUniverse class>>classUGlobalInstaller (in category 'accessing system') ----- classUGlobalInstaller ^Smalltalk at: #UGlobalInstaller ifAbsent: [ self error: 'Universes code not present' ]! ----- Method: InstallerUniverse class>>classUUniverse (in category 'accessing system') ----- classUUniverse ^Smalltalk at: #UUniverse ifAbsent: [ self error: 'Universes code not present' ]! ----- Method: InstallerUniverse class>>default (in category 'instance creation') ----- default ^ self universe: (self classUGlobalInstaller universe: self classUUniverse systemUniverse)! ----- Method: InstallerUniverse class>>universe: (in category 'instance creation') ----- universe: u ^ self new universe: u! ----- Method: InstallerUniverse>>basicInstall (in category 'basic interface') ----- basicInstall self packages do: [ :packageName | | potentials pkg pkgAndVersion version | pkgAndVersion := self packageAndVersionFrom: packageName. pkg := pkgAndVersion first. version := pkgAndVersion last. potentials := universe packageVersionsForPackage: pkg. pkg := version isEmpty ifTrue: [ potentials last ] ifFalse: [ version := self classUVersion readFrom: version readStream. (potentials anySatisfy: [ :p | p version = version]) ifFalse: [ ^ self error: 'version not found'] ]. universe planToInstallPackage: pkg. ]. self uniDoInstall! ----- Method: InstallerUniverse>>classUVersion (in category 'class references') ----- classUVersion ^Smalltalk at: #UVersion ifAbsent: [ self error: 'Universes code not present' ]! ----- Method: InstallerUniverse>>uniDoInstall (in category 'universes') ----- uniDoInstall self withAnswersDo: [ self universe doInstall ] ! ----- Method: InstallerUniverse>>universe (in category 'universes') ----- universe ^ universe! ----- Method: InstallerUniverse>>universe: (in category 'universes') ----- universe: u universe := u. self update.! ----- Method: InstallerUniverse>>update (in category 'public interface') ----- update (LastUniUpdate isNil or:[ (DateAndTime now - LastUniUpdate) > 600 seconds ]) ifTrue: [universe requestPackageList. LastUniUpdate := DateAndTime now]! Installer subclass: #InstallerUpdateStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Installer-Core'! ----- Method: InstallerUpdateStream>>changesetNamesFromUpdates:through: (in category 'updates') ----- changesetNamesFromUpdates: startNumber through: stopNumber "Answer the concatenation of summary strings for updates numbered in the given range" "self new changesetNamesFromUpdates: 7059 through: 7061" ^ String streamContents: [:aStream | ((ChangeSet changeSetsNamedSuchThat: [:aName | aName first isDigit and: [aName initialIntegerOrNil >= startNumber and: [aName initialIntegerOrNil <= stopNumber]]]) asArray sort: [:a :b | a name < b name]) do: [:aChangeSet | aStream cr; nextPutAll: aChangeSet summaryString]] ! ----- Method: InstallerUpdateStream>>loadUpdatesFromDisk (in category 'updates') ----- loadUpdatesFromDisk | updateDirectory updateNumbers | updateDirectory := self updateDirectoryOrNil. updateDirectory ifNil: [^ self]. updateNumbers := updateDirectory fileNames collect: [:fn | fn initialIntegerOrNil] thenSelect: [:fn | fn notNil]. self loadUpdatesFromDiskToUpdateNumber: updateNumbers max stopIfGap: false ! ----- Method: InstallerUpdateStream>>loadUpdatesFromDiskToUpdateNumber:stopIfGap: (in category 'updates') ----- loadUpdatesFromDiskToUpdateNumber: lastUpdateNumber stopIfGap: stopIfGapFlag "To use this mechanism, be sure all updates you want to have considered are in a folder named 'updates' which resides in the same directory as your image. Having done that, simply evaluate: Installer new loadUpdatesFromDiskToUpdateNumber: 100020 stopIfGap: false and all numbered updates <= lastUpdateNumber not yet in the image will be loaded in numerical order." "apparently does not use the updatelist too bad!! and to rewrite - sd 7 March 2008" | previousHighest currentUpdateNumber done fileNames aMessage updateDirectory loaded | updateDirectory := self updateDirectoryOrNil. updateDirectory ifNil: [^ self]. previousHighest := SystemVersion current highestUpdate. currentUpdateNumber := previousHighest. done := false. loaded := 0. [done] whileFalse: [currentUpdateNumber := currentUpdateNumber + 1. currentUpdateNumber > lastUpdateNumber ifTrue: [done := true] ifFalse: [fileNames := updateDirectory fileNamesMatching: currentUpdateNumber printString , '*'. fileNames size > 1 ifTrue: [^ self inform: 'ambiguity -- two files both start with ' , currentUpdateNumber printString , ' (at this point it is probably best to remedy the situation on disk, then try again.)']. fileNames size = 0 ifTrue: [Transcript cr; show: 'gap in updates from disk for update number '; print: currentUpdateNumber; show: ' found...'. done := stopIfGapFlag] ifFalse: [ChangeSet newChangesFromStream: (updateDirectory readOnlyFileNamed: fileNames first) named: fileNames first. SystemVersion current registerUpdate: currentUpdateNumber. loaded := loaded + 1]]]. aMessage := loaded = 0 ifTrue: ['No new updates found.'] ifFalse: [loaded printString , ' update(s) loaded.']. self inform: aMessage , ' Highest numbered update is now ' , (currentUpdateNumber - 1) printString , '.'! ----- Method: InstallerUpdateStream>>parseUpdateListContents: (in category 'updates') ----- parseUpdateListContents: listContentString "Parse the contents of an updates.list into {{releaseTag. {fileNames*}}*}, and return it." | sections releaseTag strm line fileNames | sections := OrderedCollection new. fileNames := OrderedCollection new: 1000. releaseTag := nil. strm := ReadStream on: listContentString. [strm atEnd] whileFalse: [line := strm nextLine. line size > 0 ifTrue: [line first = $# ifTrue: [releaseTag ifNotNil: [sections addLast: {releaseTag. fileNames asArray}]. releaseTag := line allButFirst. fileNames resetTo: 1] ifFalse: [line first = $* ifFalse: [fileNames addLast: line]]]]. releaseTag ifNotNil: [sections addLast: {releaseTag. fileNames asArray}]. ^ sections asArray ! ----- Method: InstallerUpdateStream>>updateDirectoryOrNil (in category 'updates') ----- updateDirectoryOrNil ^ (FileDirectory default directoryNames includes: 'updates') ifTrue: [FileDirectory default directoryNamed: 'updates'] ifFalse: [self inform: 'Error: cannot find "updates" folder'. nil]! ----- Method: InstallerUpdateStream>>writeList:toStream: (in category 'updates') ----- writeList: listContents toStream: strm "Write a parsed updates.list out as text. This is the inverse of parseUpdateListContents:" strm reset. listContents do: [:pair | | releaseTag fileNames | releaseTag := pair first. fileNames := pair last. strm nextPut: $#; nextPutAll: releaseTag; cr. fileNames do: [:fileName | strm nextPutAll: fileName; cr]]. strm close! From commits at source.squeak.org Fri Jun 5 20:16:41 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:16:46 2015 Subject: [squeak-dev] Squeak 4.6: SqueakSSL-Tests-ul.18.mcz Message-ID: Chris Muller uploaded a new version of SqueakSSL-Tests to project Squeak 4.6: http://source.squeak.org/squeak46/SqueakSSL-Tests-ul.18.mcz ==================== Summary ==================== Name: SqueakSSL-Tests-ul.18 Author: ul Time: 15 October 2014, 9:14:41.944 pm UUID: 3a075d4b-2fd5-4b84-9f84-ffd8f5a95a50 Ancestors: SqueakSSL-Tests-ar.17 Yahoo OpenID uses yahoo.com instead of yahooapis.com. ==================== Snapshot ==================== SystemOrganization addCategory: #'SqueakSSL-Tests'! TestCase subclass: #SqueakSSLTest instanceVariableNames: 'clientReadQueue serverWriteQueue serverReadQueue clientWriteQueue sslClient sslServer clientProcess serverProcess' classVariableNames: 'CertName' poolDictionaries: '' category: 'SqueakSSL-Tests'! ----- Method: SqueakSSLTest class>>certName (in category 'accessing') ----- certName "The name of the cert to use for the test" ^CertName! ----- Method: SqueakSSLTest class>>certName: (in category 'accessing') ----- certName: aString "The name of the cert to use for the test. SqueakSSLTest certName: nil. SqueakSSLTest certName: 'Internet Widgits Pty'. SqueakSSLTest certName: '/home/andreas/certs/testcert.pem'. " CertName := aString! ----- Method: SqueakSSLTest class>>ensureValidCert (in category 'utilities') ----- ensureValidCert "Ensure that we have a valid certificate for the tests" CertName := SqueakSSL ensureSampleCert. ! ----- Method: SqueakSSLTest>>certName (in category 'setup') ----- certName "Answer the name of the cert to use in tests" ^self class certName! ----- Method: SqueakSSLTest>>expectedFailures (in category 'setup') ----- expectedFailures "If we don't have a cert all the tests fail" SqueakSSL platformName = 'Mac OS' ifTrue:[ "The following tests all need certificate selection to work properly." ^#( testConnectAccept testEncryptDecrypt testMultiFrameDecrypt testSingleByteDecrypt testSplitTlsFrameRead testStreamAccept testStreamConnect testStreamTransfer ) ] ifFalse:[^#()].! ----- Method: SqueakSSLTest>>hasCertInfo (in category 'setup') ----- hasCertInfo "Returns true if we have cert information available" ^self class certName notNil! ----- Method: SqueakSSLTest>>port (in category 'setup') ----- port ^8844! ----- Method: SqueakSSLTest>>secureSocket (in category 'setup') ----- secureSocket ^SqueakSSL secureSocket! ----- Method: SqueakSSLTest>>secureSocketStream (in category 'setup') ----- secureSocketStream ^SqueakSSL secureSocketStream! ----- Method: SqueakSSLTest>>setUp (in category 'setup') ----- setUp "The default setUp" self class ensureValidCert. clientReadQueue := serverWriteQueue := SharedQueue new. serverReadQueue := clientWriteQueue := SharedQueue new. sslClient := SqueakSSL new. sslClient readBlock:[:buffer| | inbuf | inbuf := clientReadQueue next. buffer replaceFrom: 1 to: inbuf size with: inbuf startingAt: 1. inbuf size. ]. sslClient writeBlock:[:buffer :count| clientWriteQueue nextPut: (buffer copyFrom: 1 to: count) ]. sslServer := SqueakSSL new. sslServer certName: self certName. sslServer readBlock:[:buffer| | inbuf | inbuf := serverReadQueue next. buffer replaceFrom: 1 to: inbuf size with: inbuf startingAt: 1. inbuf size. ]. sslServer writeBlock:[:buffer :count| serverWriteQueue nextPut: (buffer copyFrom: 1 to: count) ]. ! ----- Method: SqueakSSLTest>>tearDown (in category 'setup') ----- tearDown "Shut down everything" clientProcess ifNotNil:[clientProcess terminate]. serverProcess ifNotNil:[serverProcess]. sslClient ifNotNil:[sslClient destroy]. sslServer ifNotNil:[sslServer destroy]. ! ----- Method: SqueakSSLTest>>testConnectAccept (in category 'tests') ----- testConnectAccept "Tests the SqueakSSL server and client handshake. " | buf process | process := Processor activeProcess. "Separate queues so we can watch the handshake" clientReadQueue := SharedQueue new. serverWriteQueue := SharedQueue new. serverReadQueue := SharedQueue new. clientWriteQueue := SharedQueue new. "Start the connect and accept loop" clientProcess := [ [sslClient connect] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. serverProcess := [ [sslServer accept] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. "Do the handshake" buf := clientWriteQueue next. serverReadQueue nextPut: buf. buf := serverWriteQueue next. clientReadQueue nextPut: buf. buf := clientWriteQueue next. serverReadQueue nextPut: buf. buf := serverWriteQueue next. clientReadQueue nextPut: buf. "Both client and server should now be connected" self assert:(clientProcess isTerminated). self assert:(serverProcess isTerminated). self assert: sslClient isConnected. self assert: sslServer isConnected. ! ----- Method: SqueakSSLTest>>testEncryptDecrypt (in category 'tests') ----- testEncryptDecrypt "Simple encrypt/decrypt test with a single frame of data. Ensures that the common case works properly." | encrypted decrypted | self testConnectAccept. encrypted := sslClient encrypt: 'Client to Server'. decrypted := sslServer decrypt: encrypted. self assert: decrypted = 'Client to Server'. encrypted := sslServer encrypt: 'Server to Client'. decrypted := sslClient decrypt: encrypted. self assert: decrypted = 'Server to Client'. ! ----- Method: SqueakSSLTest>>testFaceBookAPI (in category 'tests') ----- testFaceBookAPI "Facebook sends incomplete data during SSL handshake. Useful for testing an edge condition in SqueakSSL." Smalltalk at: #WebClient ifPresent:[:webClient| self shouldnt:[ [webClient httpGet: 'https://graph.facebook.com/oauth/access_token'] "Allow certificate errors on the Mac since cert validation isn't implemented yet." on: SqueakSSLCertificateError do:[:ex| SqueakSSL platformName = 'Mac OS' ifTrue:[ex resume] ifFalse:[ex pass]]. ] raise: Error. ].. ! ----- Method: SqueakSSLTest>>testGooglePopStream (in category 'tests') ----- testGooglePopStream "This tests the dreaded data-in-last-handshake problem that some people have been seeing. Google mail (at times) sends the first data chunk together with the last handshake and the Windows SSL code did not handle that correctly" "self run: #testGooglePopStream" | hostName address socket response stream | hostName := 'pop.gmail.com'. address := NetNameResolver addressForName: hostName. socket := Socket newTCP. socket connectTo: address port: 995. socket waitForConnectionFor: 10. stream := self secureSocketStream on: socket. [ stream sslConnect. response := stream upToAll: String crlf. self assert: response notEmpty. ] ensure:[stream destroy]. ! ----- Method: SqueakSSLTest>>testMultiFrameDecrypt (in category 'tests') ----- testMultiFrameDecrypt "A test verifying that even if we feed multiple encrypted frames at once we get them one-by-one out of the decryptor. Mainly a test to ensure consistent plugin behavior." | encrypted decrypted | "Also does setup" self testConnectAccept. "Encrypt the text" encrypted := #( 'Hello World' 'This is a test' 'How do you do' ) collect:[:each| sslClient encrypt: each]. "Now feed the the encrypted contents at once to the decryptor" decrypted := sslServer decrypt: (encrypted inject:'' into:[:a :b| a, b]). "This should only decrypt the first frame" self assert: decrypted = 'Hello World'. "The second time (with no input) we should get the second piece." decrypted := sslServer decrypt: ''. self assert: decrypted = 'This is a test'. "The third time (with extra input) we should get the last piece from the first round." encrypted := sslClient encrypt: 'More data is coming'. decrypted := sslServer decrypt: encrypted. self assert: decrypted = 'How do you do'. "And finally the last piece" decrypted := sslServer decrypt: ''. self assert: decrypted = 'More data is coming'. ! ----- Method: SqueakSSLTest>>testSSLSockets (in category 'tests') ----- testSSLSockets "Connect client and server" | client listener server sema | [listener := SecureSocket newTCP. listener listenOn: self port backlogSize: 4. client := SecureSocket newTCP. client connectTo: #[127 0 0 1] port: self port. server := listener waitForAcceptFor: 1. "Perform SSL handshake" sema := Semaphore new. [client sslConnect. sema signal] fork. server sslAccept: self certName. sema wait. "Send data" client sendData: 'Hello World'. server waitForDataFor: 1. self assert: server receiveData = 'Hello World'. ] ensure:[ listener ifNotNil:[listener destroy]. client ifNotNil:[client destroy]. server ifNotNil:[server destroy]. ].! ----- Method: SqueakSSLTest>>testSingleByteDecrypt (in category 'tests') ----- testSingleByteDecrypt "A test verifying that even if we feed the decryptor with single bytes it produces the correct output. Mainly a test that the underlying plugin deals with corner cases correctly." | encrypted decrypted | "Also does setup" self testConnectAccept. "Encrypt the text" encrypted := sslClient encrypt: 'Hello World'. "Now feed the encrypted contents byte-by-byte into the decryptor" 1 to: encrypted size-1 do:[:i| decrypted := sslServer decrypt: (encrypted copyFrom: i to: i). self assert: decrypted isEmpty. ]. "And upon feeding the last byte we expect the result" decrypted := sslServer decrypt: (encrypted last: 1). self assert: decrypted = 'Hello World'.! ----- Method: SqueakSSLTest>>testSocketAccept (in category 'tests') ----- testSocketAccept "Tests the SecureSocketStream server handshake. " | process listener clientSocket serverSocket | process := Processor activeProcess. [listener := self secureSocket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the client for the handshake" sslClient on: clientSocket. clientProcess := [ [sslClient connect] on: Error do:[:ex| process signalException: ex]. ] forkAt: Processor activePriority + 1. "Set up the server" serverSocket sslAccept: self certName. self assert: serverSocket isConnected. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. ].! ----- Method: SqueakSSLTest>>testSocketConnect (in category 'tests') ----- testSocketConnect "Tests the SecureSocket client handshake. " | process listener clientSocket serverSocket | process := Processor activeProcess. [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := self secureSocket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the server for the handshake" sslServer on: serverSocket. serverProcess := [ [sslServer accept] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. "Set up the client using SecureSocketStream" clientSocket sslConnect. clientSocket isConnected. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. ].! ----- Method: SqueakSSLTest>>testSplitTlsFrameRead (in category 'tests') ----- testSplitTlsFrameRead "Tests the SecureSocketStream client handshake. " | process listener clientSocket serverSocket secureStream char | process := Processor activeProcess. [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the server for the handshake" sslServer on: serverSocket. serverProcess := [ | encrypted | [sslServer accept. encrypted := sslServer encrypt: 'Hello World'. 1 to: encrypted size do:[:i| sslServer writeData: (encrypted copyFrom: i to: i) count: 1. (Delay forMilliseconds: 10) wait. ]. ] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. "Set up the client using SecureSocketStream" secureStream := SecureSocketStream on: clientSocket. secureStream sslConnect. self assert: secureStream isConnected. char := secureStream next. self assert: char = $H. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. secureStream ifNotNil:[secureStream destroy]. ].! ----- Method: SqueakSSLTest>>testStreamAccept (in category 'tests') ----- testStreamAccept "Tests the SecureSocketStream server handshake. " | process listener clientSocket serverSocket secureStream | process := Processor activeProcess. [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the client for the handshake" sslClient on: clientSocket. clientProcess := [ [sslClient connect] on: Error do:[:ex| process signalException: ex]. ] forkAt: Processor activePriority + 1. "Set up the client using SecureSocketStream" secureStream := SecureSocketStream on: serverSocket. secureStream sslAccept: self certName. self assert: secureStream isConnected. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. secureStream ifNotNil:[secureStream destroy]. ].! ----- Method: SqueakSSLTest>>testStreamConnect (in category 'tests') ----- testStreamConnect "Tests the SecureSocketStream client handshake. " | process listener clientSocket serverSocket secureStream | process := Processor activeProcess. [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up the server for the handshake" sslServer on: serverSocket. serverProcess := [ [sslServer accept] on: Error do:[:ex| process signalException: ex]. "uncomment for debugging" ] forkAt: Processor activePriority + 1. "Set up the client using SecureSocketStream" secureStream := SecureSocketStream on: clientSocket. secureStream sslConnect. self assert: secureStream isConnected. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. secureStream ifNotNil:[secureStream destroy]. ].! ----- Method: SqueakSSLTest>>testStreamTransfer (in category 'tests') ----- testStreamTransfer "Tests the SecureSocketStream data transfer" | listener clientSocket serverSocket serverStream clientStream | [listener := Socket newTCP. listener listenOn: self port backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: self port. clientSocket waitForConnectionFor: 1. serverSocket := listener waitForAcceptFor: 1. self assert: clientSocket isConnected. self assert: serverSocket notNil. self assert: serverSocket isConnected. "Set up client and server streams" serverStream := self secureSocketStream on: serverSocket. serverProcess := [ [serverStream sslAccept: self certName] on: Error do:[:ex| serverStream destroy]. ] forkAt: Processor activePriority + 1. clientStream := self secureSocketStream on: clientSocket. clientStream sslConnect. self assert: clientStream isConnected. self assert: serverStream isConnected. clientStream nextPutAll: 'Hello World'; flush. self assert: (serverStream next: 11) = 'Hello World'. serverStream nextPutAll: 'The other way'; flush. self assert: (clientStream next: 13) = 'The other way'. ] ensure:[ listener ifNotNil:[listener destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. clientStream ifNotNil:[clientStream destroy]. serverStream ifNotNil:[serverStream destroy]. ].! ----- Method: SqueakSSLTest>>testYahooOpenID (in category 'tests') ----- testYahooOpenID "Yahoo sends an SSL shutdown sequence which we didn't handle in the past. Also, there were some issues with SecureSocketStream that were unearthed by using it via WebClient's chunking method (not easy to reproduce without WC)." Smalltalk at: #WebClient ifPresent:[:webClient| self shouldnt:[ [webClient httpGet: 'https://open.login.yahoo.com/openid/op/auth'] "Allow certificate errors on the Mac since cert validation isn't implemented yet." on: SqueakSSLCertificateError do:[:ex| SqueakSSL platformName = 'Mac OS' ifTrue:[ex resume] ifFalse:[ex pass]]. ] raise: Error. ].. ! From commits at source.squeak.org Fri Jun 5 20:16:51 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:16:55 2015 Subject: [squeak-dev] Squeak 4.6: XML-Parser-bf.37.mcz Message-ID: Chris Muller uploaded a new version of XML-Parser to project Squeak 4.6: http://source.squeak.org/squeak46/XML-Parser-bf.37.mcz ==================== Summary ==================== Name: XML-Parser-bf.37 Author: bf Time: 8 December 2014, 2:16:57.135 am UUID: 47f3a2f8-de17-43b8-96f8-beef7a7c8200 Ancestors: XML-Parser-fbs.36 Restore timestamps lost in assignment conversion. ==================== Snapshot ==================== SystemOrganization addCategory: #'XML-Parser'! ----- Method: String>>applyLanguageInfomation: (in category '*xml-parser') ----- applyLanguageInfomation: languageEnvironment | leadingChar | leadingChar := languageEnvironment leadingChar. self withIndexDo: [:each :idx | each asciiValue > 255 ifTrue: [self at: idx put: (Character leadingChar: leadingChar code: each asUnicode)]]! Error subclass: #SAXException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! SAXException subclass: #SAXMalformedException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! SAXException subclass: #SAXParseException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! Error subclass: #XMLException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! XMLException subclass: #XMLInvalidException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! XMLException subclass: #XMLMalformedException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! XMLException subclass: #XMLWarningException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! Object subclass: #DTDEntityDeclaration instanceVariableNames: 'name value ndata' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! DTDEntityDeclaration class instanceVariableNames: 'contextBehavior'! DTDEntityDeclaration class instanceVariableNames: 'contextBehavior'! ----- Method: DTDEntityDeclaration class>>behaviorForContext: (in category 'accessing') ----- behaviorForContext: aContext ^self contextBehavior at: aContext! ----- Method: DTDEntityDeclaration class>>contextBehavior (in category 'accessing') ----- contextBehavior ^contextBehavior! ----- Method: DTDEntityDeclaration class>>initialize (in category 'class initialization') ----- initialize "DTDEntityDeclaration initialize" contextBehavior := Dictionary new. contextBehavior at: #content put: #include ; at: #attributeValueContent put: #includedInLiteral ; at: #attributeValue put: #forbidden ; at: #entityValue put: #bypass ; at: #dtd put: #forbidden ! ----- Method: DTDEntityDeclaration class>>leadIn (in category 'accessing') ----- leadIn ^'&'! ----- Method: DTDEntityDeclaration class>>name:value: (in category 'instance creation') ----- name: aString value: aValueString ^self new name: aString; value: aValueString! ----- Method: DTDEntityDeclaration>>bypass (in category 'behaviors') ----- bypass "Return my reference as is." ^self reference! ----- Method: DTDEntityDeclaration>>forbidden (in category 'behaviors') ----- forbidden self error: 'Forbidden reference usage'! ----- Method: DTDEntityDeclaration>>include (in category 'behaviors') ----- include "Return my expanded value." ^value ifNil: [SAXWarning signal: 'XML undefined entity ' , name printString]! ----- Method: DTDEntityDeclaration>>includedInLiteral (in category 'behaviors') ----- includedInLiteral "Return my expanded value." ^self include! ----- Method: DTDEntityDeclaration>>name (in category 'accessing') ----- name ^name! ----- Method: DTDEntityDeclaration>>name: (in category 'accessing') ----- name: aString name := aString asSymbol! ----- Method: DTDEntityDeclaration>>ndata (in category 'accessing') ----- ndata ^ndata! ----- Method: DTDEntityDeclaration>>ndata: (in category 'accessing') ----- ndata: aString ndata := aString! ----- Method: DTDEntityDeclaration>>reference (in category 'behaviors') ----- reference "Return my reference as is." ^self class leadIn , self name , ';'! ----- Method: DTDEntityDeclaration>>registerIn: (in category 'invocation') ----- registerIn: aParser aParser entity: self name put: self! ----- Method: DTDEntityDeclaration>>value (in category 'accessing') ----- value ^value! ----- Method: DTDEntityDeclaration>>value: (in category 'accessing') ----- value: aString value := aString! ----- Method: DTDEntityDeclaration>>valueForContext: (in category 'invocation') ----- valueForContext: aContext ^self perform: (self class behaviorForContext: aContext)! DTDEntityDeclaration subclass: #DTDExternalEntityDeclaration instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: DTDExternalEntityDeclaration class>>initialize (in category 'class initialization') ----- initialize "DTDExternalEntityDeclaration initialize" contextBehavior := Dictionary new. contextBehavior at: #content put: #include ; at: #attributeValueContent put: #includedInLiteral ; at: #attributeValue put: #forbidden ; at: #entityValue put: #bypass ; at: #dtd put: #forbidden ! DTDEntityDeclaration subclass: #DTDParameterEntityDeclaration instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: DTDParameterEntityDeclaration class>>initialize (in category 'class initialization') ----- initialize "DTDParameterEntityDeclaration initialize" contextBehavior := Dictionary new. contextBehavior at: #content put: #notRecognized: ; at: #attributeValueContent put: #notRecognized: ; at: #attributeValue put: #notRecognized: ; at: #entityValue put: #include: ; at: #dtd put: #includePE:! ----- Method: DTDParameterEntityDeclaration class>>leadIn (in category 'accessing') ----- leadIn ^'%'! ----- Method: DTDParameterEntityDeclaration>>includePE (in category 'behaviors') ----- includePE "Return my expanded value." ^self include! ----- Method: DTDParameterEntityDeclaration>>notRecognized (in category 'behaviors') ----- notRecognized SAXMalformedException signal: 'Malformed entity.'! ----- Method: DTDParameterEntityDeclaration>>registerIn: (in category 'invocation') ----- registerIn: aParser aParser parameterEntity: self name put: self! Object subclass: #SAXHandler instanceVariableNames: 'document driver eod' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: SAXHandler class>>on: (in category 'instance creation') ----- on: aStream | driver parser | driver := SAXDriver on: aStream. driver validating: true. parser := self new driver: driver. ^parser! ----- Method: SAXHandler class>>parseDTDFrom: (in category 'instance creation') ----- parseDTDFrom: aStream | driver parser | driver := SAXDriver on: aStream. driver validating: true. driver startParsingMarkup. parser := self new driver: driver. parser startDocument. parser parseDocument. ^parser! ----- Method: SAXHandler class>>parseDocumentFrom: (in category 'instance creation') ----- parseDocumentFrom: aStream ^self parseDocumentFrom: aStream useNamespaces: false! ----- Method: SAXHandler class>>parseDocumentFrom:useNamespaces: (in category 'instance creation') ----- parseDocumentFrom: aStream useNamespaces: aBoolean | parser | parser := self on: aStream. parser useNamespaces: aBoolean. parser startDocument. parser parseDocument. ^parser! ----- Method: SAXHandler class>>parseDocumentFromFileNamed: (in category 'instance creation') ----- parseDocumentFromFileNamed: fileName ^self parseDocumentFromFileNamed: fileName readIntoMemory: false! ----- Method: SAXHandler class>>parseDocumentFromFileNamed:readIntoMemory: (in category 'instance creation') ----- parseDocumentFromFileNamed: fileName readIntoMemory: readIntoMemory | stream xmlDoc | stream := FileDirectory default readOnlyFileNamed: fileName. readIntoMemory ifTrue: [stream := stream contentsOfEntireFile readStream]. xmlDoc := [self parseDocumentFrom: stream] ensure: [stream close]. ^xmlDoc! ----- Method: SAXHandler class>>parserOnFileNamed: (in category 'instance creation') ----- parserOnFileNamed: fileName ^self parserOnFileNamed: fileName readIntoMemory: false! ----- Method: SAXHandler class>>parserOnFileNamed:readIntoMemory: (in category 'instance creation') ----- parserOnFileNamed: fileName readIntoMemory: readIntoMemory | stream | stream := FileDirectory default readOnlyFileNamed: fileName. readIntoMemory ifTrue: [stream := stream contentsOfEntireFile readStream]. ^self on: stream! ----- Method: SAXHandler>>characters: (in category 'content') ----- characters: aString "This call corresponds to the Java SAX call characters(char[] ch, int start, int length)."! ----- Method: SAXHandler>>checkEOD (in category 'content') ----- checkEOD "Check if the document shouldn't be ended already" self eod ifTrue: [self driver errorExpected: 'No more data expected,']! ----- Method: SAXHandler>>comment: (in category 'lexical') ----- comment: commentString "This call corresponds to the Java SAX ext call comment(char[] ch, int start, int length)."! ----- Method: SAXHandler>>document (in category 'accessing') ----- document ^document! ----- Method: SAXHandler>>document: (in category 'accessing') ----- document: aDocument document := aDocument! ----- Method: SAXHandler>>documentAttributes: (in category 'content') ----- documentAttributes: attributeList! ----- Method: SAXHandler>>driver (in category 'accessing') ----- driver ^driver! ----- Method: SAXHandler>>driver: (in category 'accessing') ----- driver: aDriver driver := aDriver. driver saxHandler: self! ----- Method: SAXHandler>>endDocument (in category 'content') ----- endDocument "This call corresponds to the Java SAX call endDocument()." eod := true! ----- Method: SAXHandler>>endElement: (in category 'content') ----- endElement: elementName ! ----- Method: SAXHandler>>endElement:namespace:namespaceURI:qualifiedName: (in category 'content') ----- endElement: elementName namespace: namespace namespaceURI: namespaceURI qualifiedName: qualifiedName "This call corresponds to the Java SAX call endElement(java.lang.String namespaceURI, java.lang.String localName, java.lang.String qName). By default this call is mapped to the following more convenient call:" self endElement: elementName! ----- Method: SAXHandler>>endEntity: (in category 'lexical') ----- endEntity: entityName "This call corresponds to the Java SAX ext call endEntity(java.lang.String name)."! ----- Method: SAXHandler>>endPrefixMapping: (in category 'content') ----- endPrefixMapping: prefix "This call corresonds to the Java SAX call endPrefixMapping(java.lang.String prefix)."! ----- Method: SAXHandler>>eod (in category 'accessing') ----- eod ^eod! ----- Method: SAXHandler>>ignorableWhitespace: (in category 'content') ----- ignorableWhitespace: aString "This call corresonds to the Java SAX call ignorableWhitespace(char[] ch, int start, int length)."! ----- Method: SAXHandler>>initialize (in category 'initialize') ----- initialize eod := false! ----- Method: SAXHandler>>parseDocument (in category 'parsing') ----- parseDocument [self driver nextEntity isNil or: [self eod]] whileFalse! ----- Method: SAXHandler>>processingInstruction:data: (in category 'content') ----- processingInstruction: piName data: dataString "This call corresonds to the Java SAX call processingInstruction(java.lang.String target, java.lang.String data)."! ----- Method: SAXHandler>>resolveEntity:systemID: (in category 'entity') ----- resolveEntity: publicID systemID: systemID "This call corresonds to the Java SAX call resolveEntity(java.lang.String publicId, java.lang.String systemId)."! ----- Method: SAXHandler>>skippedEntity: (in category 'content') ----- skippedEntity: aString "This call corresonds to the Java SAX call skippedEntity(java.lang.String name)."! ----- Method: SAXHandler>>startCData (in category 'lexical') ----- startCData "This call corresponds to the Java SAX ext call startCData()."! ----- Method: SAXHandler>>startDTD:publicID:systemID: (in category 'lexical') ----- startDTD: declName publicID: publicID systemID: systemID "This call corresponds to the Java SAX ext call startDTD(java.lang.String name, java.lang.String publicId, java.lang.String systemId)."! ----- Method: SAXHandler>>startDocument (in category 'content') ----- startDocument "This call corresonds to the Java SAX call startDocument()."! ----- Method: SAXHandler>>startElement:attributeList: (in category 'content') ----- startElement: elementName attributeList: attributeList ! ----- Method: SAXHandler>>startElement:namespaceURI:namespace:attributeList: (in category 'content') ----- startElement: localName namespaceURI: namespaceUri namespace: namespace attributeList: attributeList "This call corresonds to the Java SAX call startElement(java.lang.String namespaceURI, java.lang.String localName, java.lang.String qName, Attributes atts). By default this call is mapped to the following more convenient call:" self startElement: localName attributeList: attributeList! ----- Method: SAXHandler>>startEntity: (in category 'lexical') ----- startEntity: entityName "This call corresponds to the Java SAX ext call startEntity(java.lang.String name)."! ----- Method: SAXHandler>>startPrefixMapping:uri: (in category 'content') ----- startPrefixMapping: prefix uri: uri "This call corresonds to the Java SAX call startPrefixMapping(java.lang.String prefix, java.lang.String uri)."! ----- Method: SAXHandler>>useNamespaces: (in category 'accessing') ----- useNamespaces: aBoolean self driver useNamespaces: aBoolean! SAXHandler subclass: #XMLDOMParser instanceVariableNames: 'entity stack incremental' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLDOMParser class>>addressBookXMLWithDTD (in category 'examples') ----- addressBookXMLWithDTD "XMLDOMParser addressBookXMLWithDTD" ^self parseDocumentFrom: XMLTokenizer addressBookXMLWithDTD readStream useNamespaces: true! ----- Method: XMLDOMParser class>>parseDocumentFrom: (in category 'instance creation') ----- parseDocumentFrom: aStream ^self parseDocumentFrom: aStream useNamespaces: false! ----- Method: XMLDOMParser class>>parseDocumentFrom:useNamespaces: (in category 'instance creation') ----- parseDocumentFrom: aStream useNamespaces: aBoolean ^(super parseDocumentFrom: aStream useNamespaces: aBoolean) document! ----- Method: XMLDOMParser>>characters: (in category 'content') ----- characters: aString | newElement | newElement := XMLStringNode string: aString. self top addContent: newElement. ! ----- Method: XMLDOMParser>>defaultNamespace (in category 'private') ----- defaultNamespace ^self top ifNotNil: [self top namespace]! ----- Method: XMLDOMParser>>documentAttributes: (in category 'content') ----- documentAttributes: attributeList self document version: (attributeList at: 'version' ifAbsent: [nil]). self document encoding: (attributeList at: 'encoding' ifAbsent: [nil]). self document requiredMarkup: (attributeList at: 'requiredMarkup' ifAbsent: [nil]). ! ----- Method: XMLDOMParser>>domDocument (in category 'parsing') ----- domDocument [self startDocument; parseDocument] ensure: [self driver stream close]. ^document! ----- Method: XMLDOMParser>>endDocument (in category 'content') ----- endDocument self pop. super endDocument! ----- Method: XMLDOMParser>>endElement: (in category 'content') ----- endElement: elementName | currentElement | currentElement := self pop. currentElement name = elementName ifFalse: [self driver errorExpected: 'End tag "', elementName , '" doesn''t match "' , currentElement name , '".']! ----- Method: XMLDOMParser>>endElement:namespace:namespaceURI:qualifiedName: (in category 'content') ----- endElement: localName namespace: namespace namespaceURI: uri qualifiedName: qualifiedName | currentElement | currentElement := self pop. (currentElement namespace isNil or: [currentElement namespace = self defaultNamespace]) ifTrue: [ currentElement localName = localName ifFalse: [self driver errorExpected: 'End tag "', localName , '" doesn''t match "' , currentElement localName , '".']] ifFalse: [ currentElement qualifiedName = qualifiedName ifFalse: [self driver errorExpected: 'End tag "', qualifiedName , '" doesn''t match "' , currentElement qualifiedName , '".']]! ----- Method: XMLDOMParser>>incremental (in category 'accessing') ----- incremental ^incremental! ----- Method: XMLDOMParser>>incremental: (in category 'accessing') ----- incremental: aBoolean incremental := aBoolean! ----- Method: XMLDOMParser>>initialize (in category 'initialize') ----- initialize super initialize. stack := OrderedCollection new. incremental := false! ----- Method: XMLDOMParser>>nextEntity (in category 'parsing') ----- nextEntity | currentTop | currentTop := self top. [self driver nextEntity isNil or: [self top ~~ currentTop]] whileTrue. ^entity! ----- Method: XMLDOMParser>>nextEntityStart (in category 'parsing') ----- nextEntityStart [self driver nextEntity. self stack isEmpty] whileTrue. ^entity! ----- Method: XMLDOMParser>>pop (in category 'private') ----- pop | oldTop | oldTop := self stack removeLast. entity := oldTop. ^oldTop! ----- Method: XMLDOMParser>>processingInstruction:data: (in category 'content') ----- processingInstruction: piName data: dataString | newElement | newElement := XMLPI target: piName data: dataString. self top addElement: newElement! ----- Method: XMLDOMParser>>push: (in category 'private') ----- push: anObject self stack add: anObject. entity := anObject ! ----- Method: XMLDOMParser>>stack (in category 'private') ----- stack ^stack! ----- Method: XMLDOMParser>>startDocument (in category 'content') ----- startDocument self document: XMLDocument new. self push: self document ! ----- Method: XMLDOMParser>>startElement:attributeList: (in category 'content') ----- startElement: elementName attributeList: attributeList | newElement | newElement := XMLElement named: elementName attributes: attributeList. self incremental ifFalse: [self stack isEmpty ifFalse: [self top addElement: newElement]]. self push: newElement! ----- Method: XMLDOMParser>>startElement:namespaceURI:namespace:attributeList: (in category 'content') ----- startElement: localName namespaceURI: namespaceUri namespace: namespace attributeList: attributeList | newElement | "newElement := namespace = self defaultNamespace ifTrue: [XMLElement named: localName namespace: nil uri: nil attributes: attributeList] ifFalse: [XMLElement named: localName namespace: namespace uri: namespaceUri attributes: attributeList]." newElement := XMLElement named: localName namespace: namespace uri: namespaceUri attributes: attributeList. self incremental ifFalse: [self stack isEmpty ifFalse: [self top addElement: newElement]]. self push: newElement! ----- Method: XMLDOMParser>>top (in category 'private') ----- top ^self stack isEmpty ifTrue: [nil] ifFalse: [self stack last]! Object subclass: #XMLNamespaceScope instanceVariableNames: 'scope currentBindings useNamespaces validateAttributes' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLNamespaceScope>>currentScope (in category 'private') ----- currentScope ^self scope last! ----- Method: XMLNamespaceScope>>declareNamespace:uri: (in category 'scope') ----- declareNamespace: ns uri: uri "Declare the given name space prefix with the given URL" ns = 'xmlns' ifTrue: [^self defaultNamespace: uri]. self establishLocalBindings. currentBindings removeKey: ns ifAbsent: []. currentBindings at: ns put: uri! ----- Method: XMLNamespaceScope>>defaultNamespace (in category 'accessing') ----- defaultNamespace ^self currentScope first! ----- Method: XMLNamespaceScope>>defaultNamespace: (in category 'accessing') ----- defaultNamespace: ns "Declare the default namespace." self currentScope at: 1 put: ns! ----- Method: XMLNamespaceScope>>enterScope (in category 'scope') ----- enterScope self scope addLast: { self defaultNamespace. nil. currentBindings. }! ----- Method: XMLNamespaceScope>>establishLocalBindings (in category 'private') ----- establishLocalBindings (self currentScope at: 2) ifNil: [ currentBindings := currentBindings copy. self currentScope at: 2 put: currentBindings]! ----- Method: XMLNamespaceScope>>initScope (in category 'private') ----- initScope scope := OrderedCollection new: 20. currentBindings := Dictionary new. scope addLast: {'http://www.w3.org/TR/REC-xml-names'. currentBindings. nil. }. ! ----- Method: XMLNamespaceScope>>leaveScope (in category 'scope') ----- leaveScope | leftScope | leftScope := self scope removeLast. currentBindings := (self currentScope at: 2) ifNil: [leftScope at: 3]! ----- Method: XMLNamespaceScope>>namespaceAliases: (in category 'private') ----- namespaceAliases: namespace "Locate all namespaces that are aliases of the given URI." | aliases uri | aliases := Set new. uri := self namespaceURIOf: namespace ifAbsent: [self parseError: 'Attribute refers to undefined namespace ' , namespace asString ]. currentBindings keysAndValuesDo: [:ns :u | (u = uri and: [ns ~= namespace]) ifTrue: [aliases add: ns]]. ^ aliases! ----- Method: XMLNamespaceScope>>namespaceURIOf: (in category 'accessing') ----- namespaceURIOf: ns "Retrieve the URI of the given namespace prefix, if it is defined. A nil namespace returns the global namespace" ^ self namespaceURIOf: ns ifAbsent: [ nil ]! ----- Method: XMLNamespaceScope>>namespaceURIOf:ifAbsent: (in category 'accessing') ----- namespaceURIOf: ns ifAbsent: aBlock "Retrieve the URI of the given namespace prefix, if it is defined. A nil namespace returns the default namespace. If no namespace can be found the value of the block is returned" ^ns ifNil: [self defaultNamespace] ifNotNil: [currentBindings at: ns ifAbsent: aBlock]! ----- Method: XMLNamespaceScope>>namespaces (in category 'accessing') ----- namespaces ^currentBindings! ----- Method: XMLNamespaceScope>>scope (in category 'private') ----- scope scope ifNil: [self initScope]. ^scope! ----- Method: XMLNamespaceScope>>validateAttributes: (in category 'validation') ----- validateAttributes: attributeList "check all attribute namespaces are defined and not duplicated by aliasing" attributeList keysDo: [:attrName | | namespace localName | self splitName: attrName into: [:ns :ln | namespace := ns. localName := ln]. namespace ifNotNil: [ (self namespaceAliases: namespace) do: [:alias | (attributeList includesKey: alias , ':' , localName) ifTrue: [self parseError: 'Attributes ' , attrName , ' and ' , alias , ':' , localName , ' are aliased to namespace ' , (self namespaceURIOf: namespace) ]]]]! Object subclass: #XMLNode instanceVariableNames: '' classVariableNames: 'CanonicalTable' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLNode>>addContent: (in category 'accessing') ----- addContent: contentString SAXParseException signal: 'Illegal string data.'! ----- Method: XMLNode>>contentsDo: (in category 'enumerating') ----- contentsDo: aBlock! ----- Method: XMLNode>>elementsAndContentsDo: (in category 'enumerating') ----- elementsAndContentsDo: aBlock self elementsDo: aBlock! ----- Method: XMLNode>>elementsDo: (in category 'enumerating') ----- elementsDo: aBlock! ----- Method: XMLNode>>firstTagNamed: (in category 'searching') ----- firstTagNamed: aSymbol "Return the first encountered node with the specified tag. Pass the message on" self elementsDo: [:node | | answer | (answer := node firstTagNamed: aSymbol) ifNotNil: [^answer]]. ^nil! ----- Method: XMLNode>>firstTagNamed:with: (in category 'searching') ----- firstTagNamed: aSymbol with: aBlock "Return the first encountered node with the specified tag that allows the block to evaluate to true. Pass the message on" self elementsDo: [:node | | answer | (answer := node firstTagNamed: aSymbol with: aBlock) ifNotNil: [^answer]]. ^nil! ----- Method: XMLNode>>isProcessingInstruction (in category 'testing') ----- isProcessingInstruction ^false! ----- Method: XMLNode>>isTag (in category 'testing') ----- isTag ^false! ----- Method: XMLNode>>isText (in category 'testing') ----- isText ^false! ----- Method: XMLNode>>printOn: (in category 'printing') ----- printOn: stream self printXMLOn: (XMLWriter on: stream)! ----- Method: XMLNode>>printXMLOn: (in category 'printing') ----- printXMLOn: writer self subclassResponsibility! ----- Method: XMLNode>>tagsNamed:childrenDo: (in category 'searching') ----- tagsNamed: aSymbol childrenDo: aOneArgumentBlock "Evaluate aOneArgumentBlock for all children who match" self elementsDo: [:each | each tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock]! ----- Method: XMLNode>>tagsNamed:childrenDoAndRecurse: (in category 'searching') ----- tagsNamed: aSymbol childrenDoAndRecurse: aOneArgumentBlock "Evaluate aOneArgumentBlock for all children who match and recurse" self elementsDo: [:each | each tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock]! ----- Method: XMLNode>>tagsNamed:contentsDo: (in category 'searching') ----- tagsNamed: aSymbol contentsDo: aBlock "Evaluate aBlock for all of the contents of the receiver. The receiver has no tag, so pass the message on" self elementsDo: [:each | each tagsNamed: aSymbol contentsDo: aBlock]! ----- Method: XMLNode>>tagsNamed:do: (in category 'searching') ----- tagsNamed: aSymbol do: aOneArgumentBlock "Search for nodes with tag aSymbol. When encountered evaluate aOneArgumentBlock" self elementsDo: [:each | each tagsNamed: aSymbol do: aOneArgumentBlock]! ----- Method: XMLNode>>tagsNamed:ifReceiverDo: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock "Handled only by XMLElement subclass" ! ----- Method: XMLNode>>tagsNamed:ifReceiverDoAndRecurse: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock "Recurse all children" self elementsDo: [:each | each tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock]! ----- Method: XMLNode>>tagsNamed:ifReceiverOrChildDo: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverOrChildDo: aOneArgumentBlock "Recurse all children" self elementsDo: [:each | each tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock]! XMLNode subclass: #XMLNodeWithElements instanceVariableNames: 'elementsAndContents uri namespace parent' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! XMLNodeWithElements subclass: #XMLDocument instanceVariableNames: 'dtd version encoding requiredMarkup' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLDocument>>dtd (in category 'accessing') ----- dtd ^dtd! ----- Method: XMLDocument>>dtd: (in category 'accessing') ----- dtd: aDTD dtd := aDTD! ----- Method: XMLDocument>>encoding (in category 'accessing') ----- encoding ^encoding ifNil: ['UTF-8']! ----- Method: XMLDocument>>encoding: (in category 'accessing') ----- encoding: aString encoding := aString! ----- Method: XMLDocument>>printCanonicalOn: (in category 'printing') ----- printCanonicalOn: aStream | writer | writer := XMLWriter on: aStream. writer canonical: true. self printXMLOn: writer! ----- Method: XMLDocument>>printXMLOn: (in category 'printing') ----- printXMLOn: writer version ifNotNil: [writer xmlDeclaration: self version encoding: self encoding]. super printXMLOn: writer! ----- Method: XMLDocument>>requiredMarkup (in category 'accessing') ----- requiredMarkup ^requiredMarkup! ----- Method: XMLDocument>>requiredMarkup: (in category 'accessing') ----- requiredMarkup: aString requiredMarkup := aString! ----- Method: XMLDocument>>root (in category 'accessing') ----- root "return my root element" ^ self topElement ! ----- Method: XMLDocument>>version (in category 'accessing') ----- version ^version! ----- Method: XMLDocument>>version: (in category 'accessing') ----- version: aString version := aString! XMLNodeWithElements subclass: #XMLElement instanceVariableNames: 'name attributes' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLElement class>>named: (in category 'instance creation') ----- named: aString ^self new name: aString! ----- Method: XMLElement class>>named:attributes: (in category 'instance creation') ----- named: aString attributes: attributeList ^self new name: aString; setAttributes: attributeList! ----- Method: XMLElement class>>named:namespace:uri:attributes: (in category 'instance creation') ----- named: aString namespace: ns uri: uri attributes: attributeList ^self new name: aString; namespace: ns uri: uri; setAttributes: attributeList! ----- Method: XMLElement>>@ (in category 'accessing') ----- @ aSymbol "shorthand form" ^ self at: aSymbol ! ----- Method: XMLElement>>addContent: (in category 'initialize') ----- addContent: contentString self addElement: contentString! ----- Method: XMLElement>>allAttributes (in category 'accessing') ----- allAttributes ^ self attributes asOrderedCollection! ----- Method: XMLElement>>at: (in category 'accessing') ----- at: aSymbol ^ self attributeAt: aSymbol ifAbsent: [''] ! ----- Method: XMLElement>>attributeAt: (in category 'accessing') ----- attributeAt: attributeName ^self attributeAt: attributeName ifAbsent: [nil]! ----- Method: XMLElement>>attributeAt:ifAbsent: (in category 'accessing') ----- attributeAt: attributeName ifAbsent: aBlock ^self attributes at: attributeName ifAbsent: [^aBlock value]! ----- Method: XMLElement>>attributeAt:put: (in category 'accessing') ----- attributeAt: attributeName put: attributeValue self attributes at: attributeName asSymbol put: attributeValue! ----- Method: XMLElement>>attributes (in category 'accessing') ----- attributes ^attributes ifNil: [attributes := Dictionary new]! ----- Method: XMLElement>>characterData (in category 'accessing') ----- characterData ^self contentString! ----- Method: XMLElement>>contentString (in category 'accessing') ----- contentString | contentElements | contentElements := self elementsAndContents. ^(contentElements size > 0 and: [contentElements first isText]) ifTrue: [contentElements first string] ifFalse: ['']! ----- Method: XMLElement>>contentStringAt: (in category 'accessing') ----- contentStringAt: entityName ^(self elementAt: entityName ifAbsent: [^'']) contentString! ----- Method: XMLElement>>contents (in category 'accessing') ----- contents ^self elementsAndContents select: [:each | each isText]! ----- Method: XMLElement>>contentsDo: (in category 'enumerating') ----- contentsDo: aBlock self elementsAndContentsDo: [:each | each isText ifTrue: [aBlock value: each]]! ----- Method: XMLElement>>elements (in category 'accessing') ----- elements ^self elementsAndContents select: [:each | each isText not]! ----- Method: XMLElement>>elementsAndContentsDo: (in category 'enumerating') ----- elementsAndContentsDo: aBlock self elementsAndContents do: aBlock! ----- Method: XMLElement>>elementsDo: (in category 'enumerating') ----- elementsDo: aBlock self elementsAndContentsDo: [:each | each isText ifFalse: [aBlock value: each]]! ----- Method: XMLElement>>firstTagNamed: (in category 'searching') ----- firstTagNamed: aSymbol "Return the first encountered node with the specified tag. If it is not the receiver, pass the message on" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [^self]. ^super firstTagNamed: aSymbol ! ----- Method: XMLElement>>firstTagNamed:with: (in category 'searching') ----- firstTagNamed: aSymbol with: aBlock "Return the first encountered node with the specified tag that allows the block to evaluate to true. Pass the message on" ((self localName == aSymbol or: [self tag == aSymbol]) and: [aBlock value: self]) ifTrue: [^self]. ^super firstTagNamed: aSymbol with: aBlock.! ----- Method: XMLElement>>isEmpty (in category 'testing') ----- isEmpty "Answer true if the receiver is empty" ^self elementsAndContents isEmpty! ----- Method: XMLElement>>isTag (in category 'testing') ----- isTag ^true! ----- Method: XMLElement>>localName (in category 'name space') ----- localName ^ name! ----- Method: XMLElement>>name (in category 'accessing') ----- name ^ self qualifiedName! ----- Method: XMLElement>>name: (in category 'initialize') ----- name: aString name := aString asSymbol! ----- Method: XMLElement>>parent (in category 'accessing') ----- parent ^ parent! ----- Method: XMLElement>>parent: (in category 'accessing') ----- parent: anXMLElement parent := anXMLElement ! ----- Method: XMLElement>>printXMLOn: (in category 'printing') ----- printXMLOn: writer "Print the receiver in XML form" writer startElement: self name attributeList: self attributes. (writer canonical not and: [self isEmpty]) ifTrue: [writer endEmptyTag: self name] ifFalse: [ writer endTag. self elementsAndContentsDo: [:content | content printXMLOn: writer]. writer endTag: self name]! ----- Method: XMLElement>>qualifiedName (in category 'name space') ----- qualifiedName ^self namespace ifNil: [self localName] ifNotNil: [self namespace , ':' , self localName]! ----- Method: XMLElement>>setAttributes: (in category 'initialize') ----- setAttributes: newAttributes attributes := newAttributes! ----- Method: XMLElement>>tag (in category 'accessing') ----- tag ^ self name asSymbol! ----- Method: XMLElement>>tagsNamed:contentsDo: (in category 'searching') ----- tagsNamed: aSymbol contentsDo: aBlock "Evaluate aBlock for all of the contents of the receiver if the receiver tag equals aSymbol. Pass the message on" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [self contentsDo: aBlock]. super tagsNamed: aSymbol contentsDo: aBlock! ----- Method: XMLElement>>tagsNamed:do: (in category 'searching') ----- tagsNamed: aSymbol do: aOneArgumentBlock "If the receiver tag equals aSymbol, evaluate aOneArgumentBlock with the receiver. Continue the search" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [aOneArgumentBlock value: self]. super tagsNamed: aSymbol do: aOneArgumentBlock! ----- Method: XMLElement>>tagsNamed:ifReceiverDo: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock "If the receiver tag equals aSymbol, evaluate aOneArgumentBlock with the receiver" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [aOneArgumentBlock value: self] ! ----- Method: XMLElement>>tagsNamed:ifReceiverDoAndRecurse: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock "If the receiver tag equals aSymbol, evaluate aOneArgumentBlock with the receiver. Then recurse through all the children" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [aOneArgumentBlock value: self]. super tagsNamed: aSymbol ifReceiverDoAndRecurse: aOneArgumentBlock! ----- Method: XMLElement>>tagsNamed:ifReceiverOrChildDo: (in category 'searching') ----- tagsNamed: aSymbol ifReceiverOrChildDo: aOneArgumentBlock "If the receiver tag equals aSymbol, evaluate aOneArgumentBlock with the receiver. For each of the receivers children do the same. Do not go beyond direct children" (self localName == aSymbol or: [self tag == aSymbol]) ifTrue: [aOneArgumentBlock value: self]. super tagsNamed: aSymbol ifReceiverDo: aOneArgumentBlock! ----- Method: XMLElement>>valueFor: (in category 'accessing') ----- valueFor: aSymbol ^self valueFor: aSymbol ifAbsent: ['']! ----- Method: XMLElement>>valueFor:ifAbsent: (in category 'accessing') ----- valueFor: aSymbol ifAbsent: aBlock ^self attributes at: aSymbol ifAbsent: aBlock! ----- Method: XMLNodeWithElements>>addElement: (in category 'accessing') ----- addElement: element self elementsAndContents add: element! ----- Method: XMLNodeWithElements>>addEntity:value: (in category 'accessing') ----- addEntity: entityName value: entityValue self entities add: entityName->entityValue! ----- Method: XMLNodeWithElements>>elementAt: (in category 'accessing') ----- elementAt: entityName ^self elementAt: entityName ifAbsent: [nil]! ----- Method: XMLNodeWithElements>>elementAt:ifAbsent: (in category 'accessing') ----- elementAt: entityName ifAbsent: aBlock elementsAndContents ifNil: [^aBlock value]. ^self elements detect: [:each | each isProcessingInstruction not and: [each name = entityName or: [each localName = entityName]]] ifNone: [^aBlock value]! ----- Method: XMLNodeWithElements>>elementUnqualifiedAt: (in category 'accessing') ----- elementUnqualifiedAt: entityName ^self elementUnqualifiedAt: entityName ifAbsent: [nil]! ----- Method: XMLNodeWithElements>>elementUnqualifiedAt:ifAbsent: (in category 'accessing') ----- elementUnqualifiedAt: entityName ifAbsent: aBlock elementsAndContents ifNil: [^aBlock value]. ^self elements detect: [:each | each localName = entityName] ifNone: [^aBlock value]! ----- Method: XMLNodeWithElements>>elements (in category 'accessing') ----- elements ^self elementsAndContents! ----- Method: XMLNodeWithElements>>elementsAndContents (in category 'accessing') ----- elementsAndContents elementsAndContents ifNil: [elementsAndContents := OrderedCollection new]. ^elementsAndContents! ----- Method: XMLNodeWithElements>>elementsDo: (in category 'enumerating') ----- elementsDo: aBlock self elements do: aBlock! ----- Method: XMLNodeWithElements>>namespace (in category 'name space') ----- namespace ^ namespace! ----- Method: XMLNodeWithElements>>namespace:uri: (in category 'name space') ----- namespace: ns uri: u namespace := ns. uri := u! ----- Method: XMLNodeWithElements>>namespaceURI (in category 'name space') ----- namespaceURI ^ uri! ----- Method: XMLNodeWithElements>>printXMLOn: (in category 'printing') ----- printXMLOn: writer self elementsDo: [:element | element printXMLOn: writer]! ----- Method: XMLNodeWithElements>>removeElement: (in category 'accessing') ----- removeElement: element "Used to purge certain elements from a document after parsing." self elementsAndContents remove: element ifAbsent: []! ----- Method: XMLNodeWithElements>>topElement (in category 'accessing') ----- topElement ^self elements first! XMLNode subclass: #XMLPI instanceVariableNames: 'target data' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLPI class>>target:data: (in category 'instance creation') ----- target: targetName data: aString ^self new target: targetName; data: aString! ----- Method: XMLPI>>data (in category 'accessing') ----- data ^data! ----- Method: XMLPI>>data: (in category 'accessing') ----- data: aString data := aString! ----- Method: XMLPI>>isProcessingInstruction (in category 'testing') ----- isProcessingInstruction ^true! ----- Method: XMLPI>>printXMLOn: (in category 'printing') ----- printXMLOn: writer writer pi: self target data: self data! ----- Method: XMLPI>>target (in category 'accessing') ----- target ^target! ----- Method: XMLPI>>target: (in category 'accessing') ----- target: aString target := aString! XMLNode subclass: #XMLStringNode instanceVariableNames: 'string' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLStringNode class>>string: (in category 'instance creation') ----- string: aString ^self new string: aString! ----- Method: XMLStringNode>>characterData (in category 'accessing') ----- characterData ^self string! ----- Method: XMLStringNode>>isText (in category 'testing') ----- isText ^true! ----- Method: XMLStringNode>>printXMLOn: (in category 'printing') ----- printXMLOn: writer writer pcData: self string! ----- Method: XMLStringNode>>string (in category 'accessing') ----- string ^string ifNil: ['']! ----- Method: XMLStringNode>>string: (in category 'accessing') ----- string: aString string := aString! Object subclass: #XMLTokenizer instanceVariableNames: 'stream nestedStreams entities externalEntities parameterEntities parsingMarkup markedPosition peekChar validating nameBuffer attributeBuffer' classVariableNames: 'CharEscapes DigitTable LiteralChars NameDelimiters SeparatorTable' poolDictionaries: '' category: 'XML-Parser'! !XMLTokenizer commentStamp: '' prior: 0! XMLTokenizer bolot@cc.gatech.edu breaks the stream of characters into a stream of XMLnodes (aka token stream) token stream is used by XMLparser to generate XMLdocument tree! XMLTokenizer subclass: #SAXDriver instanceVariableNames: 'saxHandler scope useNamespaces validateAttributes languageEnvironment' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: SAXDriver>>handleCData: (in category 'handling tokens') ----- handleCData: aString self saxHandler checkEOD; characters: aString! ----- Method: SAXDriver>>handleComment: (in category 'handling tokens') ----- handleComment: aString self saxHandler checkEOD; comment: aString! ----- Method: SAXDriver>>handleEndDocument (in category 'handling tokens') ----- handleEndDocument self saxHandler endDocument! ----- Method: SAXDriver>>handleEndTag: (in category 'handling tokens') ----- handleEndTag: elementName | namespace localName namespaceURI qualifiedName | self usesNamespaces ifTrue: [ self splitName: elementName into: [:ns :ln | namespace := ns. localName := ln]. "ensure our namespace is defined" namespace ifNil: [ namespace := self scope defaultNamespace. qualifiedName := namespace , ':' , elementName] ifNotNil: [ namespaceURI := self scope namespaceURIOf: namespace. namespaceURI ifNil: [self parseError: 'Start tag ' , elementName , ' refers to undefined namespace ' , namespace asString]. qualifiedName := elementName]. "call the handler" self saxHandler checkEOD; endElement: localName namespace: namespace namespaceURI: namespaceURI qualifiedName: qualifiedName. self scope leaveScope] ifFalse: [ "call the handler" self saxHandler checkEOD; endElement: elementName namespace: nil namespaceURI: nil qualifiedName: elementName]! ----- Method: SAXDriver>>handlePCData: (in category 'handling tokens') ----- handlePCData: aString self languageEnvironment ifNotNil: [aString applyLanguageInfomation: self languageEnvironment]. self saxHandler checkEOD; characters: aString! ----- Method: SAXDriver>>handlePI:data: (in category 'handling tokens') ----- handlePI: piTarget data: piData self saxHandler checkEOD; processingInstruction: piTarget data: piData! ----- Method: SAXDriver>>handleStartDocument (in category 'handling tokens') ----- handleStartDocument self saxHandler startDocument! ----- Method: SAXDriver>>handleStartTag:attributes:namespaces: (in category 'handling tokens') ----- handleStartTag: elementName attributes: attributeList namespaces: namespaces | localName namespace namespaceURI | (attributeList includesKey: 'xml:lang') ifTrue: [languageEnvironment := LanguageEnvironment localeID: (LocaleID isoString: (attributeList at: 'xml:lang'))]. self usesNamespaces ifTrue: [ self scope enterScope. "declare any namespaces" namespaces keysAndValuesDo: [:ns :uri | self scope declareNamespace: ns uri: uri]. self splitName: elementName into: [:ns :ln | namespace := ns. localName := ln]. "ensure our namespace is defined" namespace ifNil: [namespace := self scope defaultNamespace] ifNotNil: [ namespaceURI := self scope namespaceURIOf: namespace. namespaceURI ifNil: [self parseError: 'Start tag ' , elementName , ' refers to undefined namespace ' , namespace asString]]. self validatesAttributes ifTrue: [self scope validateAttributes: attributeList]. "call the handler" self saxHandler checkEOD; startElement: localName namespaceURI: namespaceURI namespace: namespace attributeList: attributeList] ifFalse: [ "call the handler" self saxHandler checkEOD; startElement: elementName namespaceURI: nil namespace: nil attributeList: attributeList]! ----- Method: SAXDriver>>handleWhitespace: (in category 'handling tokens') ----- handleWhitespace: aString self saxHandler checkEOD; ignorableWhitespace: aString! ----- Method: SAXDriver>>handleXMLDecl:namespaces: (in category 'handling tokens') ----- handleXMLDecl: attributes namespaces: namespaces self saxHandler checkEOD; documentAttributes: attributes. self usesNamespaces ifTrue: [ namespaces keysAndValuesDo: [:ns :uri | self scope declareNamespace: ns uri: uri]]! ----- Method: SAXDriver>>initialize (in category 'initialization') ----- initialize super initialize. useNamespaces := false. validateAttributes := false! ----- Method: SAXDriver>>languageEnvironment (in category 'accessing') ----- languageEnvironment ^languageEnvironment! ----- Method: SAXDriver>>saxHandler (in category 'accessing') ----- saxHandler ^saxHandler! ----- Method: SAXDriver>>saxHandler: (in category 'accessing') ----- saxHandler: aHandler saxHandler := aHandler! ----- Method: SAXDriver>>scope (in category 'namespaces') ----- scope scope ifNil: [scope := XMLNamespaceScope new]. ^scope! ----- Method: SAXDriver>>splitName:into: (in category 'namespaces') ----- splitName: aName into: twoArgsBlock "Split the name into namespace and local name (the block arguments). Handle both qualified and unqualified names using the default name space" | i ns ln | i := aName lastIndexOf: $:. i = 0 ifTrue: [ ns := nil. ln := aName] ifFalse: [ ns := aName copyFrom: 1 to: (i - 1). ln := aName copyFrom: i+1 to: aName size]. twoArgsBlock value: ns value: ln! ----- Method: SAXDriver>>useNamespaces: (in category 'accessing') ----- useNamespaces: aBoolean useNamespaces := aBoolean! ----- Method: SAXDriver>>usesNamespaces (in category 'testing') ----- usesNamespaces ^useNamespaces! ----- Method: SAXDriver>>validatesAttributes (in category 'testing') ----- validatesAttributes ^validateAttributes! XMLTokenizer subclass: #XMLParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! !XMLParser commentStamp: 'Alexandre.Bergel 6/1/2009 10:03' prior: 0! This is a generic parser. There is two ways to parse XML files, either using SAX, or using DOM. Both ways are supported in the XML-Parser package. SAX is event-based while DOM is tree-based. Ask google for more information! ----- Method: XMLParser>>attribute:value: (in category 'callbacks') ----- attribute: aSymbol value: aString "This method is called for each attribute/value pair in a start tag" ^self subclassResponsibility! ----- Method: XMLParser>>beginStartTag:asPI: (in category 'callbacks') ----- beginStartTag: aSymbol asPI: aBoolean "This method is called for at the beginning of a start tag. The asPI parameter defines whether or not the tag is a 'processing instruction' rather than a 'normal' tag." ^self subclassResponsibility! ----- Method: XMLParser>>endStartTag: (in category 'callbacks') ----- endStartTag: aSymbol "This method is called at the end of the start tag after all of the attributes have been processed" ^self subclassResponsibility! ----- Method: XMLParser>>endTag: (in category 'callbacks') ----- endTag: aSymbol "This method is called when the parser encounters either an end tag or the end of a unary tag" ^self subclassResponsibility! ----- Method: XMLParser>>handleCData: (in category 'handling tokens') ----- handleCData: aString self text: aString! ----- Method: XMLParser>>handleEndTag: (in category 'handling tokens') ----- handleEndTag: aString self endTag: aString! ----- Method: XMLParser>>handlePCData: (in category 'handling tokens') ----- handlePCData: aString self text: aString! ----- Method: XMLParser>>handleStartTag:attributes: (in category 'handling tokens') ----- handleStartTag: tagName attributes: attributes self beginStartTag: tagName asPI: false. attributes keysAndValuesDo: [:key :value | self attribute: key value: value]. self endStartTag: tagName! ----- Method: XMLParser>>text: (in category 'callbacks') ----- text: aString "This method is called for the blocks of text between tags. It preserves whitespace, but has all of the enclosed entities expanded" ^self subclassResponsibility! ----- Method: XMLTokenizer class>>addressBookXML (in category 'examples') ----- addressBookXML ^'
One of the most talented actresses on Daytime. Kassie plays the devious and beautiful Blair Cramer on ABC's "One Life To Live."
'! ----- Method: XMLTokenizer class>>addressBookXMLWithDTD (in category 'examples') ----- addressBookXMLWithDTD ^'
One of the most talented actresses on Daytime. Kassie plays the devious and beautiful Blair Cramer on ABC's "One Life To Live."
'! ----- Method: XMLTokenizer class>>exampleAddressBook (in category 'examples') ----- exampleAddressBook | tokenizer | "XMLTokenizer exampleAddressBook" tokenizer := XMLTokenizer on: self addressBookXML readStream. [tokenizer next notNil] whileTrue: []! ----- Method: XMLTokenizer class>>exampleAddressBookWithDTD (in category 'examples') ----- exampleAddressBookWithDTD | tokenizer | "XMLTokenizer exampleAddressBookWithDTD" tokenizer := XMLTokenizer on: self addressBookXMLWithDTD readStream. [tokenizer next notNil] whileTrue: []! ----- Method: XMLTokenizer class>>initialize (in category 'class initialization') ----- initialize "XMLTokenizer initialize" CharEscapes := CharacterSet newFrom: #( $& $" $' $> $< ). SeparatorTable := CharacterSet new. #(9 10 12 13 32) do: [:each | SeparatorTable add: each asCharacter]. LiteralChars := CharacterSet newFrom: #( $: $- $_ $= $.). 0 to: 255 do: [:i | | char | char := i asCharacter. (char isDigit or: [char isLetter]) ifTrue: [LiteralChars add: char]]. NameDelimiters := CharacterSet new. #(9 10 12 13 32 61 "$= asInteger 61" 62 "$> asInteger" 47 "$/ asInteger") do: [:each | NameDelimiters add: each asCharacter]. DigitTable := Array new: 256. DigitTable atAllPut: -1. ($0 to: $9) do: [:each | DigitTable at: each asciiValue put: each digitValue]. ($a to: $f) do: [:each | DigitTable at: each asciiValue put: each digitValue]. ($A to: $F) do: [:each | DigitTable at: each asciiValue put: each digitValue]. ! ----- Method: XMLTokenizer class>>isCharEscape: (in category 'accessing') ----- isCharEscape: entityValue ^entityValue size = 1 and: [CharEscapes includes: entityValue first]! ----- Method: XMLTokenizer class>>on: (in category 'instance creation') ----- on: aStream ^self new parseStream: aStream! ----- Method: XMLTokenizer>>atEnd (in category 'streaming') ----- atEnd nestedStreams == nil ifTrue: [^peekChar == nil and: [stream atEnd]]. ^stream atEnd ifTrue: [ self popNestingLevel. self atEnd] ifFalse: [false]! ----- Method: XMLTokenizer>>checkAndExpandReference: (in category 'tokenizing') ----- checkAndExpandReference: parsingContext | referenceString nextChar | nextChar := self peek. self validating ifFalse: [^nil]. nextChar == $& ifTrue: [ self next. self peek == $# ifTrue: [^self pushStream: (ReadStream on: self nextCharReference asString)]. referenceString := self nextLiteral. self next == $; ifFalse: [self errorExpected: ';']. self handleEntity: referenceString in: parsingContext ] ifFalse: [ ((nextChar == $% and: [self parsingMarkup]) and: [parsingContext == #entityValue]) ifTrue: [ self skipSeparators. referenceString := self nextLiteral. self handleEntity: referenceString in: parsingContext]]. self atEnd ifTrue: [self errorExpected: 'Character expected.']. ^nextChar! ----- Method: XMLTokenizer>>checkNestedStream (in category 'streaming') ----- checkNestedStream nestedStreams == nil ifFalse: [(peekChar == nil and: [self stream atEnd]) ifTrue: [ self popNestingLevel. self checkNestedStream]] ! ----- Method: XMLTokenizer>>conditionalInclude: (in category 'tokenizing') ----- conditionalInclude: conditionalKeyword conditionalKeyword = 'INCLUDE' ifTrue: [^true]. conditionalKeyword = 'IGNORE' ifTrue: [^false]. ^self conditionalInclude: (self parameterEntity: conditionalKeyword) value! ----- Method: XMLTokenizer>>endDocTypeDecl (in category 'tokenizing dtd') ----- endDocTypeDecl "Skip ]>" self next; next. ^nil! ----- Method: XMLTokenizer>>endParsingMarkup (in category 'private') ----- endParsingMarkup parsingMarkup := false! ----- Method: XMLTokenizer>>entities (in category 'entities') ----- entities entities ifNil: [entities := self initEntities]. ^entities! ----- Method: XMLTokenizer>>entity: (in category 'entities') ----- entity: refName ^self validating ifTrue: [self entities at: refName ifAbsentPut: [self parseError: 'XML undefined entity ' , refName printString]] ifFalse: [DTDEntityDeclaration name: refName value: ''] ! ----- Method: XMLTokenizer>>entity:put: (in category 'entities') ----- entity: refName put: aReference "Only the first declaration of an entity is valid so if there is already one don't register the new value." self entities at: refName ifAbsentPut: [aReference]! ----- Method: XMLTokenizer>>errorExpected: (in category 'errors') ----- errorExpected: expectedString | actualString | actualString := ''. self atEnd ifFalse: [ actualString := [self next: 20] on: Error do: ['']]. self parseError: 'XML expected ' , expectedString printString , ': ' , actualString! ----- Method: XMLTokenizer>>externalEntities (in category 'entities') ----- externalEntities externalEntities ifNil: [externalEntities := Dictionary new]. ^externalEntities! ----- Method: XMLTokenizer>>externalEntity: (in category 'entities') ----- externalEntity: refName ^self entities at: refName ifAbsentPut: ['']! ----- Method: XMLTokenizer>>fastStreamStringContents: (in category 'private') ----- fastStreamStringContents: writeStream | newSize | newSize := writeStream position. ^(String new: newSize) replaceFrom: 1 to: newSize with: writeStream originalContents startingAt: 1! ----- Method: XMLTokenizer>>handleCData: (in category 'handling tokens') ----- handleCData: aString self log: 'CData: ' , aString! ----- Method: XMLTokenizer>>handleComment: (in category 'handling tokens') ----- handleComment: aString self log: 'Comment: ' , aString! ----- Method: XMLTokenizer>>handleEndDocument (in category 'handling tokens') ----- handleEndDocument self log: 'End Doc '! ----- Method: XMLTokenizer>>handleEndTag: (in category 'handling tokens') ----- handleEndTag: aString self log: 'End tag: ' , aString! ----- Method: XMLTokenizer>>handleEntity:in: (in category 'entities') ----- handleEntity: referenceString in: parsingContext | entity entityValue | entity := self entity: referenceString. entityValue := entity valueForContext: parsingContext. (self class isCharEscape: entityValue) ifTrue: [entityValue := entity reference]. self pushStream: (ReadStream on: entityValue asString)! ----- Method: XMLTokenizer>>handlePCData: (in category 'handling tokens') ----- handlePCData: aString self log: 'PCData: ' , aString! ----- Method: XMLTokenizer>>handlePI:data: (in category 'handling tokens') ----- handlePI: piTarget data: piData self log: 'PI: ' , piTarget , ' data ' , piData! ----- Method: XMLTokenizer>>handleStartDocument (in category 'handling tokens') ----- handleStartDocument self log: 'Start Doc'! ----- Method: XMLTokenizer>>handleStartTag:attributes: (in category 'handling tokens') ----- handleStartTag: tagName attributes: attributes self log: 'Start tag: ' , tagName. attributes keysAndValuesDo: [:key :value | self log: key , '->' , value]! ----- Method: XMLTokenizer>>handleWhitespace: (in category 'handling tokens') ----- handleWhitespace: aString self log: 'Whitespace: ' , aString! ----- Method: XMLTokenizer>>handleXMLDecl:namespaces: (in category 'handling tokens') ----- handleXMLDecl: attributes namespaces: namespaces attributes keysAndValuesDo: [:key :value | self log: key , '->' , value]! ----- Method: XMLTokenizer>>hasNestedStreams (in category 'streaming') ----- hasNestedStreams ^nestedStreams notNil! ----- Method: XMLTokenizer>>initEntities (in category 'entities') ----- initEntities | ents | ents := Dictionary new. ents at: 'amp' put: (DTDEntityDeclaration name: 'amp' value: '&'); at: 'quot' put: (DTDEntityDeclaration name: 'quot' value: '"'); at: 'apos' put: (DTDEntityDeclaration name: 'apos' value: ''''); at: 'gt' put: (DTDEntityDeclaration name: 'gt' value: '>'); at: 'lt' put: (DTDEntityDeclaration name: 'lt' value: '<'). ^ents! ----- Method: XMLTokenizer>>initialize (in category 'initialize') ----- initialize parsingMarkup := false. validating := false. attributeBuffer := WriteStream on: (String new: 128). nameBuffer := WriteStream on: (String new: 128)! ----- Method: XMLTokenizer>>log: (in category 'private') ----- log: aString "Transcript show: aString; cr"! ----- Method: XMLTokenizer>>malformedError: (in category 'errors') ----- malformedError: errorString SAXMalformedException signal: errorString! ----- Method: XMLTokenizer>>match:into: (in category 'streaming') ----- match: subCollection into: resultStream "Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found. No wildcards, and case does matter." | pattern startMatch | pattern := ReadStream on: subCollection. startMatch := nil. [pattern atEnd] whileFalse: [self atEnd ifTrue: [^ false]. (self next) = (pattern next) ifTrue: [pattern position = 1 ifTrue: [startMatch := self position]] ifFalse: [pattern position: 0. startMatch ifNotNil: [ self position: startMatch. startMatch := nil]]]. ^ true ! ----- Method: XMLTokenizer>>nestedStreams (in category 'private') ----- nestedStreams nestedStreams ifNil: [nestedStreams := OrderedCollection new]. ^nestedStreams! ----- Method: XMLTokenizer>>next (in category 'streaming') ----- next "Return the next character from the current input stream. If the current stream is at end pop to next nesting level if there is one. Due to the potential nesting of original document, included documents and replacment texts the streams are held in a stack representing the nested streams. The current stream is the top one." | nextChar | peekChar ifNil: [ nestedStreams ifNotNil: [self checkNestedStream]. ^nextChar := stream next] ifNotNil: [ nextChar := peekChar. peekChar := nil. ^nextChar]. ! ----- Method: XMLTokenizer>>nextAttributeInto:namespaces: (in category 'tokenizing') ----- nextAttributeInto: attributes namespaces: namespaces | attrName attrValue | attrName := self nextName. self skipSeparators. self next == $= ifFalse: [self errorExpected: '=']. self skipSeparators. attrValue := self nextAttributeValue. (self usesNamespaces and: [(attrName findString: 'xmlns') = 1]) ifTrue: [attrName size > 6 ifTrue: [namespaces at: (attrName copyFrom: 7 to: attrName size) put: attrValue] ifFalse: [namespaces at: attrName put: attrValue]] ifFalse: [attributes at: attrName put: attrValue]! ----- Method: XMLTokenizer>>nextAttributeValue (in category 'tokenizing') ----- nextAttributeValue | delimiterChar attributeValueStream nextChar nextPeek referenceString entity entityValue | delimiterChar := self next. (delimiterChar == $" or: [delimiterChar == $']) ifFalse: [self errorExpected: 'Attribute value delimiter expected.']. attributeValueStream := attributeBuffer reset. [ nextPeek := nextChar := self next. nextChar ifNil: [self errorExpected: 'Character expected.']. nextChar == $& ifTrue: [ self peek == $# ifTrue: [ nextPeek := nil. nextChar := self nextCharReference] ifFalse: [ referenceString := self nextLiteral. self next == $; ifFalse: [self errorExpected: ';']. entity := self entity: referenceString. entityValue := entity valueForContext: #content. (self class isCharEscape: entityValue) ifTrue: [ nextPeek := nil. nextChar := entityValue first] ifFalse: [ entityValue := entityValue asString. entityValue isEmpty ifTrue: [nextPeek := nextChar := nil] ifFalse: [ self pushStream: (ReadStream on: entityValue asString). nextPeek := nextChar := self next]]]]. nextPeek == delimiterChar] whileFalse: [ nextChar ifNotNil: [attributeValueStream nextPut: nextChar]]. ^self fastStreamStringContents: attributeValueStream " ^attributeValueStream contents"! ----- Method: XMLTokenizer>>nextCDataContent (in category 'tokenizing') ----- nextCDataContent | cdata | "Skip $[ " self next. cdata := self nextUpToAll: ']]>'. self handleCData: cdata ! ----- Method: XMLTokenizer>>nextCDataOrConditional (in category 'tokenizing') ----- nextCDataOrConditional | nextChar conditionalKeyword | "Skip [" self next. self skipSeparators. nextChar := self peek. nextChar == $% ifTrue: [ self checkAndExpandReference: (self parsingMarkup ifTrue: [#dtd] ifFalse: [#content]). conditionalKeyword := self nextLiteral. self skipSeparators. ^self next == $[ ifTrue: [ self skipSeparators. self nextIncludeSection: (self conditionalInclude: conditionalKeyword)] ifFalse: [self errorExpected: '[' ]]. nextChar == $C ifTrue: [ ^self nextLiteral = 'CDATA' ifTrue: [self peek == $[ ifTrue: [self nextCDataContent] ifFalse: [self errorExpected: '[' ]] ifFalse: [self errorExpected: 'CData']]. self errorExpected: 'CData or declaration' ! ----- Method: XMLTokenizer>>nextCharReference (in category 'tokenizing') ----- nextCharReference | base charValue | self next == $# ifFalse: [self errorExpected: 'character reference']. base := self peek == $x ifTrue: [ self next. 16] ifFalse: [10]. charValue := [self readNumberBase: base] on: Error do: [:ex | self errorExpected: 'Number.']. (self next) == $; ifFalse: [self errorExpected: '";"']. ^Unicode value: charValue! ----- Method: XMLTokenizer>>nextComment (in category 'tokenizing') ----- nextComment | string | "Skip first -" self next. self next == $- ifFalse: [self errorExpected: 'second comment $-']. string := self nextUpToAll: '-->'. self handleComment: string! ----- Method: XMLTokenizer>>nextDocType (in category 'tokenizing dtd') ----- nextDocType | declType | declType := self nextLiteral. declType = 'DOCTYPE' ifTrue: [ self startParsingMarkup. ^self nextDocTypeDecl]. self errorExpected: 'markup declaration, not ' , declType printString! ----- Method: XMLTokenizer>>nextDocTypeDecl (in category 'tokenizing dtd') ----- nextDocTypeDecl | nextChar | self skipSeparators. self nextLiteral. self skipSeparators. self peek == $[ ifFalse: [[nextChar := self peek. nextChar == $> or: [nextChar == $[ ]] whileFalse: [self next]]. self peek == $[ ifTrue: [ self next. [self skipSeparators. self peek == $]] whileFalse: [ self checkAndExpandReference: #dtd. self nextNode]. self next == $] ifFalse: [self errorExpected: ']' ]]. self skipSeparators. self next == $> ifFalse: [self errorExpected: '>' ]. self endParsingMarkup! ----- Method: XMLTokenizer>>nextEndTag (in category 'tokenizing') ----- nextEndTag | tagName | "Skip /" self next. tagName := self nextName. self skipSeparators. (self nextTrimmedBlanksUpTo: $>) ifNotEmpty: [self parseError: 'XML invalid end tag ' , tagName]. self handleEndTag: tagName! ----- Method: XMLTokenizer>>nextEntity (in category 'tokenizing') ----- nextEntity "return the next XMLnode, or nil if there are no more. Fixed to retain leading whitespace when PCDATA is detected." |whitespace| "branch, depending on what the first character is" whitespace := self nextWhitespace. self atEnd ifTrue: [self handleEndDocument. ^ nil]. self checkAndExpandReference: (self parsingMarkup ifTrue: [#dtd] ifFalse: [#content]). ^self peek = $< ifTrue: [self nextNode] ifFalse: [whitespace isEmpty ifFalse: [self pushBack: whitespace]. self nextPCData]! ----- Method: XMLTokenizer>>nextEntityDeclaration (in category 'tokenizing dtd') ----- nextEntityDeclaration | entityName entityDef referenceClass reference | self skipSeparators. referenceClass := self peek == $% ifTrue: [ self next. self skipSeparators. DTDParameterEntityDeclaration] ifFalse: [DTDEntityDeclaration]. entityName := self nextLiteral. self skipSeparators. entityDef := (self peek == $" or: [self peek == $']) ifTrue: [self nextEntityValue] ifFalse: [self nextExternalId]. self skipUpTo: $>. reference := referenceClass name: entityName value: entityDef. reference registerIn: self. ^reference! ----- Method: XMLTokenizer>>nextEntityValue (in category 'tokenizing') ----- nextEntityValue | delimiterChar entityValueStream nextChar nextPeek referenceString entity entityValue | delimiterChar := self next. (delimiterChar == $" or: [delimiterChar == $']) ifFalse: [self errorExpected: 'Entity value delimiter expected.']. entityValueStream := WriteStream on: (String new). [ nextPeek := nextChar := self peek. nextChar ifNil: [self errorExpected: 'Character expected.']. nextChar == $& ifTrue: [ self next. self peek == $# ifTrue: [ nextPeek := nil. nextChar := self nextCharReference] ifFalse: [ referenceString := self nextLiteral. self next == $; ifFalse: [self errorExpected: ';']. entity := self entity: referenceString. entityValue := entity valueForContext: #entityValue. self pushStream: (ReadStream on: entityValue asString). nextPeek := nextChar := self next]] ifFalse: [ nextChar == $% ifTrue: [ self skipSeparators. referenceString := self nextLiteral. nextChar := self handleEntity: referenceString in: #entityValue. nextPeek := nextChar := self next] ifFalse: [self next]]. nextPeek == delimiterChar] whileFalse: [ nextChar ifNotNil: [entityValueStream nextPut: nextChar]]. ^entityValueStream contents! ----- Method: XMLTokenizer>>nextExternalId (in category 'tokenizing dtd') ----- nextExternalId | extDefType systemId dir | extDefType := self nextLiteral. extDefType = 'PUBLIC' ifTrue: [ self skipSeparators. self nextPubidLiteral. self skipSeparators. self peek == $> ifFalse: [ systemId := self nextSystemLiteral]]. extDefType = 'SYSTEM' ifTrue: [ self skipSeparators. systemId := self nextSystemLiteral]. systemId ifNil: [^nil]. "The rest of this method only applies if we're reading aFileStream" (self topStream isKindOf: FileStream) ifFalse: [^'']. dir := self topStream directory. ^(dir fileExists: systemId) ifTrue: [(dir readOnlyFileNamed: systemId) contentsOfEntireFile] ifFalse: ['']! ----- Method: XMLTokenizer>>nextIncludeSection: (in category 'tokenizing') ----- nextIncludeSection: parseSection | section | "Read the file up to the next include section delimiter and parse it if parseSection is true" section := self nextUpToAll: ']]>'. parseSection ifTrue: [ self pushStream: (ReadStream on: section)]! ----- Method: XMLTokenizer>>nextLiteral (in category 'tokenizing') ----- nextLiteral | resultStream nextChar | resultStream := (String new: 10) writeStream. ((nextChar := self peek) isLetter or: [nextChar == $_]) ifFalse: [self errorExpected: 'Name literal.']. [ | resultString | nextChar := self peek. (LiteralChars includes: nextChar) ifTrue: [ nextChar == $& ifTrue: [ nextChar := self next. resultStream nextPut: (self peek == $# ifTrue: [self nextCharReference] ifFalse: [^resultStream contents])] ifFalse: [ resultStream nextPut: self next]] ifFalse: [resultString := resultStream contents. resultString isEmpty ifTrue: [self errorExpected: 'Name literal'] ifFalse: [^resultString]]] repeat! ----- Method: XMLTokenizer>>nextMarkupDeclaration (in category 'tokenizing dtd') ----- nextMarkupDeclaration | declType | declType := self nextLiteral. self validating ifFalse: [^self skipMarkupDeclaration]. declType = 'ENTITY' ifTrue: [self nextEntityDeclaration] ifFalse: [self skipMarkupDeclaration]! ----- Method: XMLTokenizer>>nextName (in category 'tokenizing') ----- nextName | nextChar | nameBuffer reset. self peek == $. ifTrue: [self malformedError: 'Character expected.']. [(nextChar := self peek) ifNil: [self errorExpected: 'Character expected.']. NameDelimiters includes: nextChar] whileFalse: [ nameBuffer nextPut: self next]. ^self fastStreamStringContents: nameBuffer! ----- Method: XMLTokenizer>>nextNode (in category 'tokenizing') ----- nextNode | nextChar | "Skip < " self next. nextChar := self peek. nextChar == $!! ifTrue: [ "Skip !!" self next. nextChar := self peek. nextChar == $- ifTrue: [^self nextComment]. nextChar == $[ ifTrue: [^self nextCDataOrConditional]. ^self parsingMarkup ifTrue: [self nextMarkupDeclaration] ifFalse: [self nextDocType]]. nextChar == $? ifTrue: [^self nextPI]. ^self nextTag! ----- Method: XMLTokenizer>>nextPCData (in category 'tokenizing') ----- nextPCData | resultStream nextChar referenceString entity entityValue nextPeek | resultStream := (String new: 10) writeStream. self validating ifFalse: [ [self peek == $<] whileFalse: [resultStream nextPut: self next]. ^self handlePCData: resultStream contents]. [ nextPeek := nextChar := self peek. nextChar ifNil: [self errorExpected: 'Character expected.']. nextChar == $& ifTrue: [ self next. self peek == $# ifTrue: [ nextPeek := nil. nextChar := self nextCharReference] ifFalse: [ referenceString := self nextLiteral. self next == $; ifFalse: [self errorExpected: ';']. entity := self entity: referenceString. entityValue := entity valueForContext: #content. (self class isCharEscape: entityValue) ifTrue: [ nextPeek := nil. nextChar := entityValue first] ifFalse: [ entityValue := entityValue asString. entityValue isEmpty ifTrue: [nextPeek := nextChar := nil] ifFalse: [ self pushStream: (ReadStream on: entityValue asString). nextPeek := nextChar := self peek]]]] ifFalse: [nextPeek == $< ifFalse: [self next]]. nextPeek == $<] whileFalse: [ nextChar ifNotNil: [resultStream nextPut: nextChar]]. self handlePCData: resultStream contents! ----- Method: XMLTokenizer>>nextPI (in category 'tokenizing') ----- nextPI | piTarget piData | "Skip ?" self next. piTarget := self nextLiteral. piTarget asUppercase = 'XML' ifTrue: [^self nextXMLDecl]. self skipSeparators. piData := self nextUpToAll: '?>'. self handlePI: piTarget data: piData! ----- Method: XMLTokenizer>>nextPubidLiteral (in category 'tokenizing') ----- nextPubidLiteral ^self nextAttributeValue! ----- Method: XMLTokenizer>>nextSystemLiteral (in category 'tokenizing') ----- nextSystemLiteral ^self nextAttributeValue! ----- Method: XMLTokenizer>>nextTag (in category 'tokenizing') ----- nextTag | tagName attributes nextChar namespaces | (self peek = $/) ifTrue: [^self nextEndTag]. tagName := self nextName. self skipSeparators. attributes := Dictionary new: 33. namespaces := Dictionary new: 5. [(nextChar := self peek) == $> or: [nextChar == $/]] whileFalse: [ self checkAndExpandReference: #content. self nextAttributeInto: attributes namespaces: namespaces. self skipSeparators.]. self handleStartTag: tagName attributes: attributes namespaces: namespaces. self next == $/ ifTrue: [ self handleEndTag: tagName. self next]. ! ----- Method: XMLTokenizer>>nextTrimmedBlanksUpTo: (in category 'streaming') ----- nextTrimmedBlanksUpTo: delimiter | resultStream nextChar | resultStream := WriteStream on: (String new: 10). nextChar := nil. [(nextChar := self next) == delimiter] whileFalse: [ nextChar == $ ifFalse: [ resultStream nextPut: nextChar]]. nextChar == delimiter ifFalse: [self parseError: 'XML no delimiting ' , delimiter printString , ' found']. ^resultStream contents ! ----- Method: XMLTokenizer>>nextUpTo: (in category 'streaming') ----- nextUpTo: delimiter | resultStream nextChar | resultStream := WriteStream on: (String new: 10). [self atEnd or: [(nextChar := self next) == delimiter]] whileFalse: [resultStream nextPut: nextChar]. nextChar == delimiter ifFalse: [self parseError: 'XML no delimiting ' , delimiter printString , ' found']. ^resultStream contents ! ----- Method: XMLTokenizer>>nextUpToAll: (in category 'streaming') ----- nextUpToAll: delimitingString | string | self unpeek. string := self upToAll: delimitingString. string ifNil: [self parseError: 'XML no delimiting ' , delimitingString printString , ' found']. ^string! ----- Method: XMLTokenizer>>nextWhitespace (in category 'tokenizing') ----- nextWhitespace | nextChar resultStream resultString| resultStream := (String new: 10) writeStream. [((nextChar := self peek) ~~ nil) and: [SeparatorTable includes: nextChar]] whileTrue: [resultStream nextPut: nextChar. self next]. (nestedStreams == nil or: [self atEnd not]) ifFalse: [self checkNestedStream. self nextWhitespace]. resultString := resultStream contents. resultString isEmpty ifFalse: [self handleWhitespace: resultString]. ^resultString! ----- Method: XMLTokenizer>>nextXMLDecl (in category 'tokenizing') ----- nextXMLDecl | attributes nextChar namespaces | self skipSeparators. attributes := Dictionary new. namespaces := Dictionary new. [(nextChar := self peek) == $?] whileFalse: [ self nextAttributeInto: attributes namespaces: namespaces. self skipSeparators.]. self next. self next == $> ifFalse: [self errorExpected: '> expected.']. (attributes includesKey: 'encoding') ifTrue: [self streamEncoding: (attributes at: 'encoding')]. self handleXMLDecl: attributes namespaces: namespaces ! ----- Method: XMLTokenizer>>parameterEntities (in category 'entities') ----- parameterEntities parameterEntities ifNil: [parameterEntities := Dictionary new]. ^parameterEntities! ----- Method: XMLTokenizer>>parameterEntity: (in category 'entities') ----- parameterEntity: refName ^self parameterEntities at: refName ifAbsent: [self parseError: 'XML undefined parameter entity ' , refName printString]! ----- Method: XMLTokenizer>>parameterEntity:put: (in category 'entities') ----- parameterEntity: refName put: aReference "Only the first declaration of an entity is valid so if there is already one don't register the new value." self parameterEntities at: refName ifAbsentPut: [aReference]! ----- Method: XMLTokenizer>>parseError: (in category 'errors') ----- parseError: errorString SAXParseException signal: errorString! ----- Method: XMLTokenizer>>parseStream: (in category 'accessing') ----- parseStream: aStream self stream: aStream! ----- Method: XMLTokenizer>>parsingMarkup (in category 'private') ----- parsingMarkup ^parsingMarkup! ----- Method: XMLTokenizer>>peek (in category 'streaming') ----- peek "Return the next character from the current input stream. If the current stream poop to next nesting level if there is one. Due to the potential nesting of original document, included documents and replacment texts the streams are held in a stack representing the nested streams. The current stream is the top one." peekChar ifNil: [ nestedStreams ifNotNil: [self checkNestedStream]. ^peekChar := stream next] ifNotNil: [^peekChar]! ----- Method: XMLTokenizer>>popNestingLevel (in category 'streaming') ----- popNestingLevel self hasNestedStreams ifTrue: [ self stream close. self stream: self nestedStreams removeLast. self nestedStreams size > 0 ifFalse: [nestedStreams := nil]]! ----- Method: XMLTokenizer>>pushBack: (in category 'streaming') ----- pushBack: aString "Fixed to push the string before the peek char (if any)." | pushBackString | pushBackString := peekChar ifNil: [aString] ifNotNil: [aString, peekChar asString]. peekChar := nil. self pushStream: (ReadStream on: pushBackString)! ----- Method: XMLTokenizer>>pushStream: (in category 'streaming') ----- pushStream: newStream "Continue parsing from the new nested stream." self unpeek. self nestedStreams addLast: self stream. self stream: newStream! ----- Method: XMLTokenizer>>readNumberBase: (in category 'private') ----- readNumberBase: base "Read a hex number from stream until encountering $; " | value digit | base = 10 ifFalse: [ | numberString | numberString := self nextUpTo: $;. self stream skip: -1. ^Integer readFrom: numberString asUppercase readStream base: base. ]. value := 0. digit := DigitTable at: self peek asciiValue. digit < 0 ifTrue: [self error: 'At least one digit expected here']. self next. value := digit. [digit := DigitTable at: self peek asciiValue. digit < 0 ifTrue: [^value] ifFalse: [ self next. value := value * base + digit] ] repeat. ^ value! ----- Method: XMLTokenizer>>skipMarkupDeclaration (in category 'tokenizing dtd') ----- skipMarkupDeclaration self skipUpTo: $>! ----- Method: XMLTokenizer>>skipSeparators (in category 'streaming') ----- skipSeparators | nextChar | [((nextChar := self peek) ~~ nil) and: [SeparatorTable includes: nextChar]] whileTrue: [self next]. (nestedStreams == nil or: [self atEnd not]) ifFalse: [ self checkNestedStream. self skipSeparators]! ----- Method: XMLTokenizer>>skipUpTo: (in category 'streaming') ----- skipUpTo: delimiter | nextChar | self unpeek. [self atEnd or: [(nextChar := self next) == delimiter]] whileFalse: []. nextChar == delimiter ifFalse: [self parseError: 'XML no delimiting ' , delimiter printString , ' found'] ! ----- Method: XMLTokenizer>>startParsingMarkup (in category 'private') ----- startParsingMarkup parsingMarkup := true! ----- Method: XMLTokenizer>>stream (in category 'private') ----- stream ^stream! ----- Method: XMLTokenizer>>stream: (in category 'private') ----- stream: newStream "Continue parsing from the new nested stream." stream := newStream! ----- Method: XMLTokenizer>>stream:upToAll: (in category 'streaming') ----- stream: aStream upToAll: aCollection "Answer a subcollection from the current access position to the occurrence (not inclusive) of aCollection. If aCollection is not in the stream, answer nil." | startPos endMatch result | startPos := aStream position. (aStream match: aCollection) ifTrue: [endMatch := aStream position. aStream position: startPos. result := aStream next: endMatch - startPos - aCollection size. aStream position: endMatch. ^ result] ifFalse: [ aStream position: startPos. ^nil]! ----- Method: XMLTokenizer>>streamEncoding: (in category 'streaming') ----- streamEncoding: encodingString Smalltalk at: #TextConverter ifPresent: [:tc | (stream respondsTo: #converter:) ifTrue: [ | converterClass | converterClass := tc defaultConverterClassForEncoding: encodingString asLowercase. converterClass ifNotNil: [stream converter: converterClass new]]]! ----- Method: XMLTokenizer>>topStream (in category 'streaming') ----- topStream ^self hasNestedStreams ifTrue: [self nestedStreams first] ifFalse: [self stream]! ----- Method: XMLTokenizer>>unpeek (in category 'streaming') ----- unpeek "Fixed to use nested stream since multi-byte streams do not properly override pushBack: to deal with multi-byte characters." peekChar ifNotNil: [self pushBack: '']! ----- Method: XMLTokenizer>>upToAll: (in category 'streaming') ----- upToAll: delimitingString "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of delimitingString. If delimitingString is not in the stream, answer the entire rest of the stream." | result | self hasNestedStreams ifFalse: [ result := self stream: self stream upToAll: delimitingString. result ifNil: [self parseError: 'XML no delimiting ' , delimitingString printString , ' found']. ^result]. result := self stream: self stream upToAll: delimitingString. result ifNotNil: [^result]. result := String streamContents: [:resultStream | resultStream nextPutAll: self stream upToEnd. self atEnd ifTrue: [self parseError: 'XML no delimiting ' , delimitingString printString , ' found']. self stream position timesRepeat: [ self atEnd ifFalse: [ resultStream nextPut: self next]]]. self pushBack: result. ^self upToAll: delimitingString! ----- Method: XMLTokenizer>>usesNamespaces (in category 'testing') ----- usesNamespaces ^false! ----- Method: XMLTokenizer>>validating (in category 'testing') ----- validating ^validating! ----- Method: XMLTokenizer>>validating: (in category 'accessing') ----- validating: aBoolean validating := aBoolean! Object subclass: #XMLWriter instanceVariableNames: 'stream stack scope scanner canonical currentIndent indentString' classVariableNames: 'XMLTranslation XMLTranslationMap' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLWriter class>>initialize (in category 'class initialization') ----- initialize "XMLWriter initialize" XMLTranslation := Dictionary new. XMLTranslation at: Character cr put: ' '; at: Character lf put: ' '; at: Character tab put: ' '; at: $& put: '&'; at: $< put: '<'; at: $> put: '>'; " at: $' put: '''; " at: $" put: '"'. XMLTranslationMap := ByteArray new: 256. XMLTranslation keysDo:[:ch| XMLTranslationMap at: ch asciiValue+1 put: 1]. ! ----- Method: XMLWriter class>>on: (in category 'instance creation') ----- on: aStream ^self basicNew initialize stream: aStream! ----- Method: XMLWriter>>attribute:value: (in category 'writing xml') ----- attribute: attributeName value: attributeValue self stream space; nextPutAll: attributeName. self eq; putAsXMLString: attributeValue! ----- Method: XMLWriter>>canonical (in category 'accessing') ----- canonical ^canonical! ----- Method: XMLWriter>>canonical: (in category 'accessing') ----- canonical: aBoolean canonical := aBoolean! ----- Method: XMLWriter>>cdata: (in category 'writing xml') ----- cdata: aString self startCData. self stream nextPutAll: aString. self endCData! ----- Method: XMLWriter>>comment: (in category 'writing xml') ----- comment: aString self startComment. self stream nextPutAll: aString. self endComment! ----- Method: XMLWriter>>declareNamespace:uri: (in category 'namespaces') ----- declareNamespace: ns uri: uri self scope declareNamespace: ns uri: uri! ----- Method: XMLWriter>>defaultNamespace (in category 'namespaces') ----- defaultNamespace ^self scope defaultNamespace! ----- Method: XMLWriter>>defaultNamespace: (in category 'namespaces') ----- defaultNamespace: ns "Declare the default namespace." self scope defaultNamespace: ns! ----- Method: XMLWriter>>endCData (in category 'private tags') ----- endCData self stream nextPutAll: ']]>'! ----- Method: XMLWriter>>endComment (in category 'private tags') ----- endComment self stream nextPutAll: ' -->'! ----- Method: XMLWriter>>endDecl: (in category 'writing dtd') ----- endDecl: type self endTag! ----- Method: XMLWriter>>endDeclaration (in category 'writing dtd') ----- endDeclaration self stream cr; nextPut: $]. self endTag! ----- Method: XMLWriter>>endEmptyTag: (in category 'writing xml') ----- endEmptyTag: tagName self popTag: tagName. self stream nextPutAll: '/>'. self canonical ifFalse: [self stream space]! ----- Method: XMLWriter>>endPI (in category 'private tags') ----- endPI self stream nextPutAll: ' ?>'! ----- Method: XMLWriter>>endTag (in category 'writing xml') ----- endTag self stream nextPutAll: '>'. self indent. "self canonical ifFalse: [self stream space]"! ----- Method: XMLWriter>>endTag: (in category 'writing xml') ----- endTag: tagName self outdent. self endTag: tagName xmlns: nil! ----- Method: XMLWriter>>endTag:xmlns: (in category 'writing xml') ----- endTag: tagName xmlns: xmlns self popTag: tagName. self stream nextPutAll: '>enterScope (in category 'namespaces') ----- enterScope self scope enterScope! ----- Method: XMLWriter>>eq (in category 'private') ----- eq self stream nextPut: $=! ----- Method: XMLWriter>>flush (in category 'writing xml') ----- flush self stream flush! ----- Method: XMLWriter>>indent (in category 'private') ----- indent currentIndent ifNotNil: [currentIndent := currentIndent +1]! ----- Method: XMLWriter>>indentString: (in category 'accessing') ----- indentString: aString currentIndent := 0. indentString := aString! ----- Method: XMLWriter>>indentTab (in category 'accessing') ----- indentTab self indentString: (String with: Character tab)! ----- Method: XMLWriter>>initialize (in category 'initialize') ----- initialize stack := OrderedCollection new. canonical := false. scope := XMLNamespaceScope new! ----- Method: XMLWriter>>leaveScope (in category 'namespaces') ----- leaveScope self scope leaveScope! ----- Method: XMLWriter>>outdent (in category 'private') ----- outdent currentIndent ifNotNil: [ stream cr. currentIndent := currentIndent-1. self writeIndent. currentIndent := currentIndent-1.]! ----- Method: XMLWriter>>pcData: (in category 'writing xml') ----- pcData: aString | lastIndex nextIndex | lastIndex := 1. "Unroll the first search to avoid copying" nextIndex := aString class findFirstInString: aString inSet: XMLTranslationMap startingAt: lastIndex. nextIndex = 0 ifTrue:[^self stream nextPutAll: aString]. [self stream nextPutAll: (aString copyFrom: lastIndex to: nextIndex-1). self stream nextPutAll: (XMLTranslation at: (aString at: nextIndex)). lastIndex := nextIndex + 1. nextIndex := aString class findFirstInString: aString inSet: XMLTranslationMap startingAt: lastIndex. nextIndex = 0] whileFalse. self stream nextPutAll: (aString copyFrom: lastIndex to: aString size).! ----- Method: XMLWriter>>pi:data: (in category 'writing xml') ----- pi: piTarget data: piData self startPI: piTarget. self stream nextPutAll: piData. self endPI! ----- Method: XMLWriter>>popTag: (in category 'private') ----- popTag: tagName | stackTop | stackTop := self stack isEmpty ifTrue: [''] ifFalse: [self stack last]. ^stackTop = tagName ifTrue: [self stack removeLast] ifFalse: [self error: 'Closing tag "' , tagName , '" does not match "' , stackTop]! ----- Method: XMLWriter>>pushTag: (in category 'private') ----- pushTag: tagName self stack add: tagName! ----- Method: XMLWriter>>putAsXMLString: (in category 'private') ----- putAsXMLString: aValue self stream nextPut: $". self pcData: aValue. self stream nextPut: $"! ----- Method: XMLWriter>>scope (in category 'private') ----- scope ^scope! ----- Method: XMLWriter>>stack (in category 'private') ----- stack ^stack! ----- Method: XMLWriter>>startCData (in category 'private tags') ----- startCData self stream nextPutAll: '>startComment (in category 'private tags') ----- startComment self stream nextPutAll: '<-- '! ----- Method: XMLWriter>>startDecl: (in category 'writing dtd') ----- startDecl: type self stream nextPutAll: '>startDecl:named: (in category 'writing dtd') ----- startDecl: type named: aString self stream nextPutAll: '>startDeclaration: (in category 'writing dtd') ----- startDeclaration: dtdName self startDecl: 'DOCTYPE' named: dtdName. self stream nextPut: $[; cr! ----- Method: XMLWriter>>startElement:attributeList: (in category 'writing xml') ----- startElement: elementName attributeList: attributeList self canonical ifFalse: [self stream cr]. self startTag: elementName. attributeList keys asArray sort do: [:key | self attribute: key value: (attributeList at: key)]! ----- Method: XMLWriter>>startPI: (in category 'private tags') ----- startPI: identifier self stream nextPutAll: '>startTag: (in category 'writing xml') ----- startTag: tagName self writeIndent. self startTag: tagName xmlns: nil! ----- Method: XMLWriter>>startTag:xmlns: (in category 'writing xml') ----- startTag: tagName xmlns: xmlns self stream nextPut: $<. (xmlns notNil and: [xmlns ~= self scope defaultNamespace]) ifTrue: [self stream nextPutAll: xmlns; nextPut: $:]. self stream nextPutAll: tagName. "self canonical ifFalse: [self stream space]." self pushTag: tagName! ----- Method: XMLWriter>>stream (in category 'accessing') ----- stream ^stream! ----- Method: XMLWriter>>stream: (in category 'accessing') ----- stream: aStream stream := aStream! ----- Method: XMLWriter>>writeIndent (in category 'private') ----- writeIndent currentIndent ifNotNil: [ currentIndent timesRepeat: [self stream nextPutAll: indentString]]! ----- Method: XMLWriter>>xmlDeclaration: (in category 'writing xml') ----- xmlDeclaration: versionString self canonical ifFalse: [ self startPI: 'xml'; attribute: 'version' value: versionString; endPI]! ----- Method: XMLWriter>>xmlDeclaration:encoding: (in category 'writing xml') ----- xmlDeclaration: versionString encoding: encodingString self canonical ifFalse: [ self startPI: 'xml'; attribute: 'version' value: versionString; attribute: 'encoding' value: encodingString; endPI. self stream flush]! ----- Method: ByteString>>applyLanguageInfomation: (in category '*xml-parser') ----- applyLanguageInfomation: languageEnvironment ! Warning subclass: #SAXWarning instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ClassTestCase subclass: #XMLParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XML-Parser'! ----- Method: XMLParserTest>>addressBookXML (in category 'source') ----- addressBookXML ^'
One of the most talented actresses on Daytime. Kassie plays the devious and beautiful Blair Cramer on ABC's "One Life To Live."
'! ----- Method: XMLParserTest>>addressBookXMLWithDTD (in category 'source') ----- addressBookXMLWithDTD ^'
One of the most talented actresses on Daytime. Kassie plays the devious and beautiful Blair Cramer on ABC's "One Life To Live."
'! ----- Method: XMLParserTest>>testExampleAddressBook (in category 'tests') ----- testExampleAddressBook | tokenizer | "self debug: #testExampleAddressBook" tokenizer := XMLTokenizer on: self addressBookXML readStream. "We enumerate the first characters of the addressbook example. The file being parsed begins with >testExampleAddressBookWithDTD (in category 'tests') ----- testExampleAddressBookWithDTD | tokenizer | "XMLTokenizer exampleAddressBookWithDTD" tokenizer := XMLTokenizer on: self addressBookXMLWithDTD readStream. "This should not raise an exception." [tokenizer next notNil] whileTrue: [].! ----- Method: XMLParserTest>>testParsing (in category 'tests') ----- testParsing | xmlDocument root firstPerson numberOfPersons | "self debug: #testParsing" xmlDocument := XMLDOMParser parseDocumentFrom: self addressBookXML readStream. self assert: (xmlDocument isKindOf: XMLDocument). root := xmlDocument root. self assert: (root class == XMLElement). "the tag has to be a symbol!!" self assert: (root firstTagNamed: 'person') isNil. self assert: (root firstTagNamed: 'addressbook') isNil. self assert: (root firstTagNamed: #addressbook) == root. numberOfPersons := 0. root tagsNamed: #person do: [:p | numberOfPersons := numberOfPersons + 1]. self assert: numberOfPersons = 4. firstPerson := root firstTagNamed: #person. self assert: (firstPerson attributeAt: #'employee-number') = 'A0000'. self assert: (firstPerson attributeAt: #'family-name') = 'Gates'. self assert: (firstPerson attributeAt: #'first-name') = 'Bob'.! ----- Method: XMLParserTest>>testParsingCharacters (in category 'tests') ----- testParsingCharacters | parser | "This test is actually not that useful. This is not the proper way of using the parser. This test is here just for specification purpose" "self debug: #testParsingCharacters" parser := XMLParser on: self addressBookXML readStream. self assert: parser next = $<. self assert: parser next = $a. self assert: parser next = $d. self assert: parser next = $d. self assert: parser next = $r.! ----- Method: XMLParserTest>>testPrintElements (in category 'tests') ----- testPrintElements | node | node:= (XMLElement new) name: 'foo'; setAttributes: (Dictionary new); yourself. self assert: node asString withBlanksTrimmed = ''. node:= (XMLElement new) name: 'foo'; setAttributes: (Dictionary newFromPairs: {'id'. '123'}); yourself. self assert: node asString withBlanksTrimmed = ''. node:= (XMLElement new) name: 'foo'; addContent: (XMLStringNode string: 'Hello World'); setAttributes: (Dictionary new); yourself. self assert: node asString withBlanksTrimmed = 'Hello World'. node:= (XMLElement new) name: 'foo'; addContent: (XMLStringNode string: 'Hello World'); setAttributes: (Dictionary newFromPairs: {'id'. '123'}); yourself. self assert: node asString withBlanksTrimmed = 'Hello World'. ! From commits at source.squeak.org Fri Jun 5 20:16:57 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:16:58 2015 Subject: [squeak-dev] Squeak 4.6: SqueakSSL-SMTP-ar.1.mcz Message-ID: Chris Muller uploaded a new version of SqueakSSL-SMTP to project Squeak 4.6: http://source.squeak.org/squeak46/SqueakSSL-SMTP-ar.1.mcz ==================== Summary ==================== Name: SqueakSSL-SMTP-ar.1 Author: ar Time: 27 November 2011, 11:40:06.998 am UUID: e091f7d9-2e75-f547-94e7-043537eb417e Ancestors: SecureSMTPClient for sending email via SSL. ==================== Snapshot ==================== SystemOrganization addCategory: #'SqueakSSL-SMTP'! SMTPClient subclass: #SecureSMTPClient instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-SMTP'! ----- Method: SecureSMTPClient class>>exampleGMailFrom:to:password: (in category 'example') ----- exampleGMailFrom: gmailAddress to: rcvrAddress password: pw "Sends email via secure smtp through GMail" | message smtpClient | smtpClient := self new. smtpClient user: gmailAddress. smtpClient password: pw. smtpClient openOnHost: (NetNameResolver addressForName: 'smtp.gmail.com') port: 465. message := MailMessage empty. message setField: 'from' toString: gmailAddress. message setField: 'to' toString: rcvrAddress. message setField: 'subject' toString: 'Hello World'. message body: (MIMEDocument contentType: 'text/plain' content: 'bla bla bla'). smtpClient mailFrom: gmailAddress to: {rcvrAddress} text: message text. smtpClient quit. ! ----- Method: SecureSMTPClient>>ensureConnection (in category 'private') ----- ensureConnection self isConnected ifTrue: [^self]. self stream ifNotNil: [self stream close]. self stream: (SecureSocketStream openConnectionToHost: self host port: self port timeout: self standardTimeout). self stream sslConnect. self checkResponse. self login! From commits at source.squeak.org Fri Jun 5 20:17:30 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:17:33 2015 Subject: [squeak-dev] Squeak 4.6: BalloonTests-egp.2.mcz Message-ID: Chris Muller uploaded a new version of BalloonTests to project Squeak 4.6: http://source.squeak.org/squeak46/BalloonTests-egp.2.mcz ==================== Summary ==================== Name: BalloonTests-egp.2 Author: egp Time: 6 March 2011, 3:52:10.157 pm UUID: a8206c39-12ee-4222-a29a-caa537e037c4 Ancestors: BalloonTests-egp.1 Test of the GradientFillStyle LRUCache false hits bug. ==================== Snapshot ==================== SystemOrganization addCategory: #'BalloonTests-Fills'! ClassTestCase subclass: #GradientFillStyleTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'BalloonTests-Fills'! !GradientFillStyleTest commentStamp: 'egp 3/6/2011 15:10' prior: 0! This tests the LRUCache operation.! ----- Method: GradientFillStyleTest>>testLRUCacheHits (in category 'tests') ----- testLRUCacheHits | gradient greenWhiteRamp redWhiteRamp | "This test proves the bug fix where modifing the LRUCache key resulted in false cache hits. The affect was that a gradient could not be modifed from the user interface." GradientFillStyle cleanUp. gradient := GradientFillStyle new colorRamp: {0.0->Color red. 1.0->Color white}. redWhiteRamp := gradient pixelRamp. "Change the first color in colorRamp" gradient firstColor: Color green forMorph: nil hand: nil. greenWhiteRamp := gradient pixelRamp. "Ensure the pixelRamp has changed" self assert: (redWhiteRamp ~= greenWhiteRamp).! From commits at source.squeak.org Fri Jun 5 20:17:47 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:17:51 2015 Subject: [squeak-dev] Squeak 4.6: SUnitGUI-mt.62.mcz Message-ID: Chris Muller uploaded a new version of SUnitGUI to project Squeak 4.6: http://source.squeak.org/squeak46/SUnitGUI-mt.62.mcz ==================== Summary ==================== Name: SUnitGUI-mt.62 Author: mt Time: 10 May 2015, 12:18:33.708 pm UUID: 23278a70-3219-2542-bdb0-1e42b35989a6 Ancestors: SUnitGUI-topa.61 Upper spacing of button bar in test runner fixed by removing some magic numbers. ==================== Snapshot ==================== SystemOrganization addCategory: #SUnitGUI! ProtoObject subclass: #TestCoverage instanceVariableNames: 'hasRun reference method' classVariableNames: '' poolDictionaries: '' category: 'SUnitGUI'! ----- Method: TestCoverage class>>on: (in category 'instance creation') ----- on: aMethodReference ^ self new initializeOn: aMethodReference! ----- Method: TestCoverage>>doesNotUnderstand: (in category 'private') ----- doesNotUnderstand: aMessage ^ method perform: aMessage selector withArguments: aMessage arguments! ----- Method: TestCoverage>>flushCache (in category 'private') ----- flushCache! ----- Method: TestCoverage>>hasRun (in category 'testing') ----- hasRun ^ hasRun! ----- Method: TestCoverage>>initializeOn: (in category 'initialization') ----- initializeOn: aMethodReference hasRun := false. reference := aMethodReference. method := reference compiledMethod! ----- Method: TestCoverage>>install (in category 'actions') ----- install reference actualClass methodDictionary at: reference methodSymbol put: self! ----- Method: TestCoverage>>mark (in category 'private') ----- mark hasRun := true! ----- Method: TestCoverage>>reference (in category 'private') ----- reference ^ reference! ----- Method: TestCoverage>>run:with:in: (in category 'evaluation') ----- run: aSelector with: anArray in: aReceiver self mark; uninstall. ^ aReceiver withArgs: anArray executeMethod: method! ----- Method: TestCoverage>>uninstall (in category 'actions') ----- uninstall reference actualClass methodDictionary at: reference methodSymbol put: method! ----- Method: TestCase class>>packageNamesUnderTest (in category '*sunitgui') ----- packageNamesUnderTest "Answer a collection of package names under test. This is used by the test runner to automatically instrument the code in these packages when checking for test coverage." ^ #()! Object subclass: #TestRunner instanceVariableNames: 'categories categoriesSelected classes classIndex classesSelected failedList failedSelected errorList errorSelected lastUpdate result previousRun categoryPattern classPattern' classVariableNames: '' poolDictionaries: '' category: 'SUnitGUI'! !TestRunner commentStamp: '' prior: 0! ! ----- Method: TestRunner class>>build (in category 'instance-creation') ----- build ^ ToolBuilder build: self new.! ----- Method: TestRunner class>>initialize (in category 'initialization') ----- initialize self registerInWorldMenu; registerInToolsFlap.! ----- Method: TestRunner class>>open (in category 'instance-creation') ----- open ^ ToolBuilder open: self new.! ----- Method: TestRunner class>>registerInToolsFlap (in category 'initialization') ----- registerInToolsFlap self environment at: #Flaps ifPresent: [ :class | class registerQuad: #( TestRunner build 'SUnit Runner' 'A production scale test-runner.' ) forFlapNamed: 'Tools'; replaceToolsFlap ].! ----- Method: TestRunner class>>registerInWorldMenu (in category 'initialization') ----- registerInWorldMenu self environment at: #TheWorldMenu ifPresent: [ :class | class registerOpenCommand: (Array with: 'Test Runner' with: (Array with: self with: #open)) ].! ----- Method: TestRunner class>>windowColorSpecification (in category 'window color') ----- windowColorSpecification ^ WindowColorSpec classSymbol: self name wording: 'Test Runner' brightColor: Color orange pastelColor: (Color r: 0.65 g: 0.753 b: 0.976) helpMessage: 'The Camp Smalltalk TestRunner tool for SUnit'! ----- Method: TestRunner>>addDeclaredPackagesUnderTestTo: (in category 'actions') ----- addDeclaredPackagesUnderTestTo: packages classesSelected do: [ :class | (class class includesSelector: #packageNamesUnderTest) ifTrue: [ class packageNamesUnderTest do: [ :name | packages add: (PackageInfo named: name) ] ] ]! ----- Method: TestRunner>>addMethodsUnderTestIn:to: (in category 'actions') ----- addMethodsUnderTestIn: packages to: methods packages do: [:package | package isNil ifFalse: [package methods do: [:method | ((#(#packageNamesUnderTest #classNamesNotUnderTest ) includes: method methodSymbol) or: [method compiledMethod isAbstract or: [method compiledMethod refersToLiteral: #ignoreForCoverage]]) ifFalse: [methods add: method]]]]! ----- Method: TestRunner>>baseClass (in category 'accessing') ----- baseClass ^ TestCase! ----- Method: TestRunner>>basicRunSuite:do: (in category 'processing') ----- basicRunSuite: aTestSuite do: aBlock self basicSetUpSuite: aTestSuite. [ | prefix | prefix := aTestSuite name isEmptyOrNil ifTrue: [ '' ] ifFalse: [ aTestSuite name, ' - ' ]. aTestSuite tests do: aBlock displayingProgress: [ :test | prefix, test printString ] every: 0 "Update the label for all tests" ] ensure: [ self basicTearDownSuite: aTestSuite ]. ! ----- Method: TestRunner>>basicSetUpSuite: (in category 'processing') ----- basicSetUpSuite: aTestSuite aTestSuite resources do: [ :each | each isAvailable ifFalse: [ each signalInitializationError ] ].! ----- Method: TestRunner>>basicTearDownSuite: (in category 'processing') ----- basicTearDownSuite: aTestSuite aTestSuite resources do: [ :each | each reset ].! ----- Method: TestRunner>>browseClass (in category 'accessing-classes') ----- browseClass (classes at: classIndex ifAbsent: [ ^ self ]) browse! ----- Method: TestRunner>>browserEnvironment (in category 'private') ----- browserEnvironment ^ Smalltalk classNamed: #BrowserEnvironment.! ----- Method: TestRunner>>buildButtonsWith: (in category 'building') ----- buildButtonsWith: aBuilder ^ aBuilder pluggablePanelSpec new model: self; layout: #horizontal; children: (self buttons collect: [ :each | aBuilder pluggableButtonSpec new model: self; label: each first; action: each second; enabled: each third; yourself ]); yourself.! ----- Method: TestRunner>>buildCategoriesWith: (in category 'building') ----- buildCategoriesWith: aBuilder ^ aBuilder pluggableMultiSelectionListSpec new model: self; list: #categoryList; menu: #categoryMenu:; getIndex: #categorySelected; setIndex: #categorySelected:; getSelectionList: #categoryAt:; setSelectionList: #categoryAt:put:; yourself.! ----- Method: TestRunner>>buildClassesWith: (in category 'building') ----- buildClassesWith: aBuilder ^ aBuilder pluggableMultiSelectionListSpec new model: self; list: #classList; menu: #classMenu:; getIndex: #classSelected; setIndex: #classSelected:; getSelectionList: #classAt:; setSelectionList: #classAt:put:; yourself.! ----- Method: TestRunner>>buildErrorListWith: (in category 'building') ----- buildErrorListWith: aBuilder ^ aBuilder pluggableListSpec new model: self; name: 'Error List'; list: #errorList; menu: #errorMenu:; getIndex: #errorSelected; setIndex: #errorSelected:; yourself.! ----- Method: TestRunner>>buildFailureListWith: (in category 'building') ----- buildFailureListWith: aBuilder ^ aBuilder pluggableListSpec new model: self; name: 'Failure List'; list: #failedList; menu: #failureMenu:; getIndex: #failedSelected; setIndex: #failedSelected:; yourself.! ----- Method: TestRunner>>buildStatusWith: (in category 'building') ----- buildStatusWith: aBuilder ^ aBuilder pluggableTextSpec new model: self; menu: #statusMenu:; color: #statusColor; getText: #statusText; yourself.! ----- Method: TestRunner>>buildWith: (in category 'building') ----- buildWith: aBuilder | window | window := aBuilder pluggableWindowSpec new model: self; label: self label; extent: self extent; children: (OrderedCollection new add: ((self buildCategoriesWith: aBuilder) frame: self categoriesFrame; yourself); add: ((self buildClassesWith: aBuilder) frame: self classesFrame; yourself); add: ((self buildStatusWith: aBuilder) frame: self statusFrame; yourself); add: ((self buildFailureListWith: aBuilder) frame: self failureListFrame; yourself); add: ((self buildErrorListWith: aBuilder) frame: self errorListFrame; yourself); add: ((self buildButtonsWith: aBuilder) frame: self buttonsFrame; yourself); yourself); yourself. ^ aBuilder build: window.! ----- Method: TestRunner>>buttonHeight (in category 'building') ----- buttonHeight ^ Preferences standardButtonFont height * 3! ----- Method: TestRunner>>buttons (in category 'accessing-ui') ----- buttons ^ #(( 'Run Selected' #runAll #hasRunnable ) ( 'Run Profiled' #runProfiled #hasRunnable ) ( 'Run Coverage' #runCoverage #hasRunnable ) ( 'Run Failures' #runFailures #hasFailures ) ( 'Run Errors' #runErrors #hasErrors ))! ----- Method: TestRunner>>buttonsFrame (in category 'building') ----- buttonsFrame ^LayoutFrame new leftFraction: 0 offset: 0; topFraction: 1 offset: self buttonHeight negated; rightFraction: 1 offset: 0; bottomFraction: 1 offset: 0! ----- Method: TestRunner>>categoriesFrame (in category 'building') ----- categoriesFrame ^LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: 0; rightFraction: 0.25 offset: 0; bottomFraction: 1 offset: self buttonHeight negated! ----- Method: TestRunner>>categoryAt: (in category 'accessing-categories') ----- categoryAt: anIndex ^ categoriesSelected includes: (categories at: anIndex ifAbsent: [ ^ false ]).! ----- Method: TestRunner>>categoryAt:put: (in category 'accessing-categories') ----- categoryAt: anInteger put: aBoolean categoriesSelected := categoriesSelected perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) with: (categories at: anInteger ifAbsent: [ ^ self ]). self changed: #categorySelected; updateClasses.! ----- Method: TestRunner>>categoryList (in category 'accessing-categories') ----- categoryList ^ categories! ----- Method: TestRunner>>categoryMenu: (in category 'accessing-categories') ----- categoryMenu: aMenu ^ aMenu title: 'Categories'; add: 'Select all' action: #selectAllCategories; add: 'Select inversion' action: #selectInverseCategories; add: 'Select none' action: #selectNoCategories; addLine; add: 'Filter...' action: #filterCategories; addLine; add: 'Refresh' action: #updateCategories; yourself.! ----- Method: TestRunner>>categorySelected (in category 'accessing-categories') ----- categorySelected ^ 0! ----- Method: TestRunner>>categorySelected: (in category 'accessing-categories') ----- categorySelected: anInteger self changed: #categorySelected.! ----- Method: TestRunner>>classAt: (in category 'accessing-classes') ----- classAt: anInteger ^ classesSelected includes: (classes at: anInteger ifAbsent: [ ^ false ]).! ----- Method: TestRunner>>classAt:put: (in category 'accessing-classes') ----- classAt: anInteger put: aBoolean classesSelected := classesSelected perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) with: (classes at: anInteger ifAbsent: [ ^ self ]). self changed: #classSelected; changed: #hasRunnable.! ----- Method: TestRunner>>classList (in category 'accessing-classes') ----- classList | offset | classes isEmpty ifTrue: [ ^ classes ]. offset := classes first allSuperclasses size. ^ classes collect: [ :each | | ident | ident := String new: 2 * (0 max: each allSuperclasses size - offset) withAll: $ . each isAbstract ifFalse: [ ident , each name ] ifTrue: [ ident asText , each name asText addAttribute: TextEmphasis italic; yourself ] ].! ----- Method: TestRunner>>classMenu: (in category 'accessing-classes') ----- classMenu: aMenu ^ aMenu title: 'Classes'; add: 'Browse' action: #browseClass; addLine; add: 'Select all' action: #selectAllClasses; add: 'Select subclasses' action: #selectSubclasses; add: 'Select inversion' action: #selectInverseClasses; add: 'Select none' action: #selectNoClasses; addLine; add: 'Filter...' action: #filterClasses; addLine; add: 'Refresh' action: #updateClasses; yourself.! ----- Method: TestRunner>>classSelected (in category 'accessing-classes') ----- classSelected ^ classIndex! ----- Method: TestRunner>>classSelected: (in category 'accessing-classes') ----- classSelected: anInteger classIndex := anInteger. self changed: #classSelected! ----- Method: TestRunner>>classesFrame (in category 'building') ----- classesFrame ^LayoutFrame new leftFraction: 0.25 offset: 0; topFraction: 0 offset: 0; rightFraction: 0.5 offset: 0; bottomFraction: 1 offset: self buttonHeight negated! ----- Method: TestRunner>>classesSelected (in category 'accessing') ----- classesSelected ^ classesSelected! ----- Method: TestRunner>>collectCoverageFor: (in category 'actions') ----- collectCoverageFor: methods | wrappers suite | wrappers := methods collect: [ :each | TestCoverage on: each ]. suite := self reset; suiteAll. [ wrappers do: [ :each | each install ]. [ self runSuite: suite ] ensure: [ wrappers do: [ :each | each uninstall ] ] ] valueUnpreemptively. wrappers := wrappers reject: [ :each | each hasRun ]. wrappers isEmpty ifTrue: [ UIManager default inform: 'Congratulations. Your tests cover all code under analysis.' ] ifFalse: [ ToolSet browseMessageSet: (wrappers collect: [ :each | each reference ]) name: 'Not Covered Code (' , (100 - (100 * wrappers size // methods size)) printString , '% Code Coverage)' autoSelect: nil ]. self saveResultInHistory! ----- Method: TestRunner>>debug: (in category 'actions') ----- debug: aTestCase self debugSuite: (TestSuite new addTest: aTestCase; yourself).! ----- Method: TestRunner>>debugSuite: (in category 'actions') ----- debugSuite: aTestSuite self basicRunSuite: aTestSuite do: [ :each | each debug ].! ----- Method: TestRunner>>defaultBackgroundColor (in category 'private') ----- defaultBackgroundColor "" ^ Preferences testRunnerWindowColor! ----- Method: TestRunner>>errorList (in category 'accessing-testing') ----- errorList ^ errorList collect: [ :each | each printString ].! ----- Method: TestRunner>>errorListFrame (in category 'building') ----- errorListFrame ^LayoutFrame new leftFraction: 0.5 offset: 0; topFraction: 0.5 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 1 offset: self buttonHeight negated! ----- Method: TestRunner>>errorMenu: (in category 'accessing-menu') ----- errorMenu: aMenu ^ self statusMenu: aMenu! ----- Method: TestRunner>>errorSelected (in category 'accessing-testing') ----- errorSelected ^ errorList indexOf: errorSelected.! ----- Method: TestRunner>>errorSelected: (in category 'accessing-testing') ----- errorSelected: anInteger errorSelected := errorList at: anInteger ifAbsent: nil. self changed: #errorSelected. errorSelected ifNotNil: [ self debug: errorSelected ].! ----- Method: TestRunner>>excludeClassesNotUnderTestFrom: (in category 'actions') ----- excludeClassesNotUnderTestFrom: methods classesSelected do: [ :class | (class class includesSelector: #classNamesNotUnderTest) ifTrue: [ class classNamesNotUnderTest do: [ :className | | theClass | theClass := Smalltalk classNamed: className. theClass ifNotNil:[ theClass methods do: [ :each | methods remove: each methodReference ifAbsent: [ ] ]. theClass class methods do: [ :each | methods remove: each methodReference ifAbsent: [ ] ]] ] ] ]! ----- Method: TestRunner>>extent (in category 'accessing-ui') ----- extent ^ 640 @ 480! ----- Method: TestRunner>>failedList (in category 'accessing-testing') ----- failedList ^ failedList collect: [ :each | each printString ].! ----- Method: TestRunner>>failedSelected (in category 'accessing-testing') ----- failedSelected ^ failedList indexOf: failedSelected.! ----- Method: TestRunner>>failedSelected: (in category 'accessing-testing') ----- failedSelected: anInteger failedSelected := failedList at: anInteger ifAbsent: nil. self changed: #failedSelected. failedSelected ifNotNil: [ self debug: failedSelected ].! ----- Method: TestRunner>>failureListFrame (in category 'building') ----- failureListFrame ^LayoutFrame new leftFraction: 0.5 offset: 0; topFraction: 0 offset: self statusHeight; rightFraction: 1 offset: 0; bottomFraction: 0.5 offset: 0! ----- Method: TestRunner>>failureMenu: (in category 'accessing-menu') ----- failureMenu: aMenu ^ aMenu! ----- Method: TestRunner>>filterCategories (in category 'accessing-categories') ----- filterCategories | pattern | pattern := UIManager default request: 'Pattern(s) to select categories:\ (separate patterns with '';'')' withCRs initialAnswer: (categoryPattern ifNil: ['*']). (pattern isNil or: [pattern isEmpty]) ifTrue: [^self]. categoriesSelected := ((categoryPattern := pattern) subStrings: ';') inject: Set new into: [:matches :subPattern| matches addAll: (categories select: [ :each | subPattern match: each]); yourself]. self changed: #allSelections; changed: #categorySelected; updateClasses! ----- Method: TestRunner>>filterClasses (in category 'accessing-classes') ----- filterClasses | pattern | pattern := UIManager default request: 'Pattern(s) to select tests:\ (separate patterns with '';'')' withCRs initialAnswer: (classPattern ifNil: '*'). (pattern isNil or: [pattern isEmpty]) ifTrue: [^self]. classesSelected := ((classPattern := pattern) subStrings: ';') inject: Set new into: [:matches :subPattern| matches addAll: (classes select: [ :each | subPattern match: each name]); yourself]. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>findCategories (in category 'utilities') ----- findCategories | visible | visible := Set new. self baseClass withAllSubclassesDo: [ :each | each category ifNotNil: [ :category | visible add: category ] ]. ^ Array streamContents: [ :stream | Smalltalk organization categories do: [ :each | (visible includes: each) ifTrue: [ stream nextPut: each ] ] ].! ----- Method: TestRunner>>findClassesForCategories: (in category 'utilities') ----- findClassesForCategories: aCollection | items | aCollection isEmpty ifTrue: [ ^ self baseClass withAllSubclasses asSet ]. items := aCollection gather: [ :category | ((Smalltalk organization listAtCategoryNamed: category) collect: [ :each | Smalltalk at: each ]) select: [ :each | each includesBehavior: self baseClass ] ]. ^ items asSet.! ----- Method: TestRunner>>hasErrors (in category 'testing') ----- hasErrors ^ result hasErrors.! ----- Method: TestRunner>>hasFailures (in category 'testing') ----- hasFailures ^ result hasFailures.! ----- Method: TestRunner>>hasHistory (in category 'history saving') ----- hasHistory self flag: #Useless. "No Senders?" ^ true! ----- Method: TestRunner>>hasProgress (in category 'history saving') ----- hasProgress result classesTested do: [:cls | (cls class methodDictionary includesKey: #lastStoredRun) ifTrue: [^ true]]. ^ false! ----- Method: TestRunner>>hasResults (in category 'history saving') ----- hasResults ^ result notNil! ----- Method: TestRunner>>hasRunnable (in category 'testing') ----- hasRunnable ^ classesSelected notEmpty.! ----- Method: TestRunner>>historyMenuList (in category 'history saving') ----- historyMenuList ^ {'** save current result **'}, (self previousRun collect: [:ts | ts printString])! ----- Method: TestRunner>>initialize (in category 'initialization') ----- initialize super initialize. failedList := errorList := Array new. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #class change: #Added using: #update; notify: self ofSystemChangesOfItem: #category change: #Added using: #update; notify: self ofSystemChangesOfItem: #class change: #Removed using: #update; notify: self ofSystemChangesOfItem: #category change: #Removed using: #update; notify: self ofSystemChangesOfItem: #class change: #Renamed using: #update; notify: self ofSystemChangesOfItem: #category change: #Renamed using: #update; notify: self ofSystemChangesOfItem: #class change: #Recategorized using: #update; notify: self ofSystemChangesOfItem: #category change: #Recategorized using: #update. self update; reset! ----- Method: TestRunner>>label (in category 'accessing-ui') ----- label ^ 'Test Runner' ! ----- Method: TestRunner>>label:forSuite: (in category 'private') ----- label: aString forSuite: aTestSuite ^ String streamContents: [ :stream | stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString. aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ]. ! ----- Method: TestRunner>>perform:orSendTo: (in category 'private') ----- perform: selector orSendTo: otherTarget "" ^ (self respondsTo: selector) ifTrue: [ self perform: selector ] ifFalse: [ super perform: selector orSendTo: otherTarget ].! ----- Method: TestRunner>>postAcceptBrowseFor: (in category 'accessing-ui') ----- postAcceptBrowseFor: aModel "Nothing to do."! ----- Method: TestRunner>>previousRun (in category 'history saving') ----- previousRun ^ previousRun ifNil: [ previousRun := OrderedCollection new ]! ----- Method: TestRunner>>promptForPackages (in category 'actions') ----- promptForPackages | packages | packages := (PackageOrganizer default packages reject: [:package | (package packageName beginsWith: 'Kernel') or: [(package packageName beginsWith: 'Collections') or: [(package packageName beginsWith: 'Exceptions') or: [(package packageName beginsWith: 'SUnit') or: [(package packageName beginsWith: 'System') or: [package packageName includesSubstring: 'Test' caseSensitive: false]]]]]]) sort: [:a :b | a packageName < b packageName]. packages := Array with: (UIManager default chooseFrom: (packages collect: [:package | package packageName]) values: packages title: 'Select Package'). ^ packages! ----- Method: TestRunner>>representsSameBrowseeAs: (in category 'accessing-ui') ----- representsSameBrowseeAs: anotherModel ^ self class = anotherModel class and: [ classesSelected = anotherModel classesSelected ]! ----- Method: TestRunner>>reset (in category 'actions') ----- reset self result: TestResult new; updateResults.! ----- Method: TestRunner>>result (in category 'accessing-testing') ----- result ^ result! ----- Method: TestRunner>>result: (in category 'accessing-testing') ----- result: aResult result := aResult! ----- Method: TestRunner>>runAll (in category 'actions') ----- runAll self reset; runSuite: self suiteAll. self saveResultInHistory! ----- Method: TestRunner>>runCoverage (in category 'actions') ----- runCoverage | packages methods | packages := Set new. self addDeclaredPackagesUnderTestTo: packages. packages isEmpty ifTrue: [ packages := self promptForPackages ]. methods := OrderedCollection new. self addMethodsUnderTestIn: packages to: methods. self excludeClassesNotUnderTestFrom: methods. methods isEmpty ifTrue: [ ^ UIManager default inform: 'No methods found for coverage analysis.' ]. self collectCoverageFor: methods ! ----- Method: TestRunner>>runErrors (in category 'actions') ----- runErrors self result instVarNamed: 'errors' put: OrderedCollection new. self runSuite: self suiteErrors.! ----- Method: TestRunner>>runFailures (in category 'actions') ----- runFailures self result instVarNamed: 'failures' put: Set new. self runSuite: self suiteFailures.! ----- Method: TestRunner>>runProfiled (in category 'actions') ----- runProfiled MessageTally spyOn: [ self runAll ].! ----- Method: TestRunner>>runSuite: (in category 'actions') ----- runSuite: aTestSuite self basicRunSuite: aTestSuite do: [ :each | self runTest: each ]. self updateResults ! ----- Method: TestRunner>>runTest: (in category 'actions') ----- runTest: aTestCase aTestCase run: result. self updateStatus: true.! ----- Method: TestRunner>>saveResultInHistory (in category 'history saving') ----- saveResultInHistory result dispatchResultsIntoHistory! ----- Method: TestRunner>>selectAllCategories (in category 'accessing-categories') ----- selectAllCategories categoriesSelected := categories asSet. self changed: #allSelections; changed: #categorySelected; updateClasses! ----- Method: TestRunner>>selectAllClasses (in category 'accessing-classes') ----- selectAllClasses "Fixed to update all selections now that the selection invalidation has been optimised." classesSelected := classes asSet. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>selectInverseCategories (in category 'accessing-categories') ----- selectInverseCategories categoriesSelected := categories asSet removeAll: categoriesSelected; yourself. self changed: #allSelections; changed: #categorySelected; updateClasses! ----- Method: TestRunner>>selectInverseClasses (in category 'accessing-classes') ----- selectInverseClasses "Fixed to update all selections now that the selection invalidation has been optimised." classesSelected := classes asSet removeAll: classesSelected; yourself. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>selectNoCategories (in category 'accessing-categories') ----- selectNoCategories categoriesSelected := Set new. self changed: #allSelections; changed: #categorySelected; updateClasses! ----- Method: TestRunner>>selectNoClasses (in category 'accessing-classes') ----- selectNoClasses "Fixed to update all selections now that the selection invalidation has been optimised." classesSelected := Set new. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>selectSubclasses (in category 'accessing-classes') ----- selectSubclasses "Fixed to update all selections now that the selection invalidation has been optimised." | classesForPackages | classesForPackages := self findClassesForCategories: categoriesSelected. classesSelected := (classesSelected gather: [ :class | class withAllSubclasses select: [ :each | classesForPackages includes: each ] ]) asSet. self changed: #allSelections; changed: #classSelected; changed: #hasRunnable! ----- Method: TestRunner>>showDiffWith: (in category 'history saving') ----- showDiffWith: aTestResult | string diff | diff := result diff: aTestResult. string := String streamContents: [:str| str nextPutAll: '----------------'; cr. str nextPutAll: 'Diff between current result with: ', aTestResult asString; cr. str nextPutAll: 'New passed: '. diff first do: [:s| str nextPutAll: s printString, ' ']. str cr. str nextPutAll: 'New failures: '. diff second do: [:s| str nextPutAll: s printString, ' ']. str cr. str nextPutAll: 'New errors: '. diff third do: [:s| str nextPutAll: s printString, ' ']. str cr]. Workspace new contents: string; openLabel: 'SUnit Progress' ! ----- Method: TestRunner>>showHistoryMenu (in category 'history saving') ----- showHistoryMenu | selectionIndex selectedPreviousResult actionIndex | selectionIndex := UIManager default chooseFrom: self historyMenuList title: 'History:'. "We pressed outside the menu" selectionIndex isZero ifTrue: [ ^ self ]. "save current result is selected" selectionIndex = 1 ifTrue: [ self previousRun addFirst: result. ^ self ]. selectedPreviousResult := self previousRun at: (selectionIndex - 1). actionIndex := (UIManager default chooseFrom: #('delete' 'show diff') title: 'Action:'). actionIndex = 1 ifTrue: [ self previousRun remove: selectedPreviousResult. ^ self ]. actionIndex = 2 ifTrue: [ self showDiffWith: selectedPreviousResult]. ! ----- Method: TestRunner>>showProgress (in category 'history saving') ----- showProgress | testCaseClasses d string | testCaseClasses := (self suiteAll tests collect: [:testCase | testCase class]) asSet. "At the end of the algorithm, d will contains all the diff between what was saved and the current result" d := Dictionary new. d at: #passed put: OrderedCollection new. d at: #failures put: OrderedCollection new. d at: #errors put: OrderedCollection new. testCaseClasses do: [ :cls | | t | (cls class methodDict includesKey: #lastStoredRun) ifTrue: [t := cls lastStoredRun. (t at: #passed) do: [:s | (result isErrorFor: cls selector: s) ifTrue: [(d at: #errors) add: {cls . s}]. (result isFailureFor: cls selector: s) ifTrue: [(d at: #failures) add: {cls . s}] ]. (t at: #failures) do: [:s | (result isPassedFor: cls selector: s) ifTrue: [(d at: #passed) add: {cls . s}]. (result isErrorFor: cls selector: s) ifTrue: [(d at: #errors) add: {cls . s}]]. (t at: #errors) do: [:s | (result isPassedFor: cls selector: s) ifTrue: [(d at: #passed) add: {cls . s}]. (result isFailureFor: cls selector: s) ifTrue: [(d at: #failures) add: {cls . s}]]]]. string := String streamContents: [:str| str nextPutAll: '----------------'; cr. str nextPutAll: 'Diff between current result and saved result'; cr. str nextPutAll: 'New passed: '. (d at: #passed) do: [:s| str nextPutAll: s printString, ' ']. str cr. str nextPutAll: 'New failures: '. (d at: #failures) do: [:s| str nextPutAll: s printString, ' ']. str cr. str nextPutAll: 'New errors: '. (d at: #errors) do: [:s| str nextPutAll: s printString, ' ']. str cr]. Workspace new contents: string; openLabel: 'SUnit Progress' string. ! ----- Method: TestRunner>>sortClass:before: (in category 'utilities') ----- sortClass: aFirstClass before: aSecondClass | first second | first := aFirstClass withAllSuperclasses reversed. second := aSecondClass withAllSuperclasses reversed. 1 to: (first size min: second size) do: [ :index | (first at: index) == (second at: index) ifFalse: [ ^ (first at: index) name <= (second at: index) name ] ]. ^ second includes: aFirstClass.! ----- Method: TestRunner>>statusColor (in category 'accessing-testing') ----- statusColor result hasErrors ifTrue: [ ^ Color red ]. result hasFailures ifTrue:[ ^ Color yellow ]. ^ Color green! ----- Method: TestRunner>>statusFrame (in category 'building') ----- statusFrame ^LayoutFrame new leftFraction: 0.5 offset: 0; topFraction: 0 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 0 offset: self statusHeight! ----- Method: TestRunner>>statusHeight (in category 'building') ----- statusHeight ^Preferences standardCodeFont height * 2 + 12! ----- Method: TestRunner>>statusMenu: (in category 'accessing-menu') ----- statusMenu: aMenu ^ aMenu add: 'History' action: #showHistoryMenu; add: 'Store result as progress reference' action: #storeResultIntoTestCases; add: 'Show progress' action: #showProgress; yourself! ----- Method: TestRunner>>statusText (in category 'accessing-testing') ----- statusText ^ result printString.! ----- Method: TestRunner>>storeResultIntoTestCases (in category 'history saving') ----- storeResultIntoTestCases result classesTested do: [:testCaseCls | testCaseCls generateLastStoredRunMethod ] ! ----- Method: TestRunner>>suiteAll (in category 'accessing') ----- suiteAll ^ TestSuite new in: [ :suite | classesSelected do: [ :each | each isAbstract ifFalse: [ each addToSuiteFromSelectors: suite ] ]. suite name: (self label: 'Test' forSuite: suite) ].! ----- Method: TestRunner>>suiteErrors (in category 'accessing') ----- suiteErrors ^ TestSuite new in: [ :suite | suite addTests: errorList; name: (self label: 'Error' forSuite: suite) ].! ----- Method: TestRunner>>suiteFailures (in category 'accessing') ----- suiteFailures ^ TestSuite new in: [ :suite | suite addTests: failedList; name: (self label: 'Failure' forSuite: suite) ].! ----- Method: TestRunner>>update (in category 'updating') ----- update self updateCategories; updateClasses! ----- Method: TestRunner>>updateCategories (in category 'updating') ----- updateCategories categories := self findCategories. categoriesSelected := categoriesSelected isNil ifTrue: [ Set new ] ifFalse: [ categoriesSelected select: [ :each | categories includes: each ] ]. self changed: #categoryList; changed: #categorySelected.! ----- Method: TestRunner>>updateClasses (in category 'updating') ----- updateClasses | classesForCategories | classesForCategories := self findClassesForCategories: categoriesSelected. classes := classesForCategories asArray sort: [ :a :b | self sortClass: a before: b ]. classIndex := 0. classesSelected := classesSelected isNil ifTrue: [ classesForCategories ] ifFalse: [ classesSelected select: [ :each | classesForCategories includes: each ] ]. self changed: #classList; changed: #classSelected; changed: #hasRunnable.! ----- Method: TestRunner>>updateResults (in category 'updating') ----- updateResults "" "" self updateStatus: false. failedList size = result failures size ifFalse: [ failedList := result failures asArray sort: [ :a :b | a printString <= b printString ]. failedSelected := nil. self changed: #failedList; changed: #failedSelected; changed: #hasFailures; changed: #hasProgress ]. errorList size = result errors size ifFalse: [ errorList := result errors asArray sort: [ :a :b | a printString <= b printString ]. errorSelected := nil. self changed: #errorList; changed: #errorSelected; changed: #hasErrors; changed: #hasProgress ].! ----- Method: TestRunner>>updateStatus: (in category 'updating') ----- updateStatus: aBoolean "Update the status display, at most once a second if aBoolean is true." (aBoolean and: [ lastUpdate = Time totalSeconds ]) ifTrue: [ ^ self ]. self changed: #statusText; changed: #statusColor. lastUpdate := Time totalSeconds.! ----- Method: TestRunner>>windowIsClosing (in category 'private') ----- windowIsClosing SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self! From commits at source.squeak.org Fri Jun 5 20:18:48 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:18:52 2015 Subject: [squeak-dev] Squeak 4.6: HelpSystem-Core-mt.78.mcz Message-ID: Chris Muller uploaded a new version of HelpSystem-Core to project Squeak 4.6: http://source.squeak.org/squeak46/HelpSystem-Core-mt.78.mcz ==================== Summary ==================== Name: HelpSystem-Core-mt.78 Author: mt Time: 14 May 2015, 6:45:57.427 pm UUID: d3d02275-f61e-8f4f-91e0-5dcf9b37c8d5 Ancestors: HelpSystem-Core-kfr.77 Class-based help topics are editable again. Help browser updates correctly after edits. ==================== Snapshot ==================== SystemOrganization addCategory: #'HelpSystem-Core-Builders'! SystemOrganization addCategory: #'HelpSystem-Core-Help'! SystemOrganization addCategory: #'HelpSystem-Core-Model'! SystemOrganization addCategory: #'HelpSystem-Core-UI'! SystemOrganization addCategory: #'HelpSystem-Core-Utilities'! (PackageInfo named: 'HelpSystem-Core') postscript: '"below, add code to be run after the loading of this package" TheWorldMainDockingBar updateInstances'! Model subclass: #AbstractHelpTopic instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !AbstractHelpTopic commentStamp: 'mt 3/24/2015 16:26' prior: 0! A HelpTopic provides content information that can be used as a help to the user. It can be labeled with a title and marked with an (optional) icon. Help topics form a hierarchy since any topic is able to have zero or more subtopics. ! ----- Method: AbstractHelpTopic>><= (in category 'comparing') ----- <= anotherHelpTopic "Priority-based: ... -3 -2 -1 nil nil nil 1 2 3 4 ..." (self priority notNil and: [anotherHelpTopic priority notNil]) ifTrue: [^ self priority <= anotherHelpTopic priority]. (self priority notNil and: [anotherHelpTopic priority isNil]) ifTrue: [^ self priority <= 0]. (self priority isNil and: [anotherHelpTopic priority notNil]) ifTrue: [^ anotherHelpTopic priority >= 0]. "Fall-back." ^ self title <= anotherHelpTopic title! ----- Method: AbstractHelpTopic>>asHelpTopic (in category 'conversion') ----- asHelpTopic ^ self! ----- Method: AbstractHelpTopic>>contents (in category 'accessing') ----- contents "Return the text contents of this topic." self subclassResponsibility.! ----- Method: AbstractHelpTopic>>hasSubtopics (in category 'testing') ----- hasSubtopics ^ self subtopics notEmpty! ----- Method: AbstractHelpTopic>>icon (in category 'accessing') ----- icon "Returns a descriptive form to support manual detection in a list of topics. Icons may encode the kind of topic." ^ nil! ----- Method: AbstractHelpTopic>>isEditable (in category 'testing') ----- isEditable ^ false! ----- Method: AbstractHelpTopic>>isSearchable (in category 'testing') ----- isSearchable ^ true! ----- Method: AbstractHelpTopic>>printOn: (in category 'printing') ----- printOn: stream | title | super printOn: stream. (title := self title) notNil ifTrue: [stream nextPutAll: '<' , title , '>'].! ----- Method: AbstractHelpTopic>>priority (in category 'accessing') ----- priority ^ nil! ----- Method: AbstractHelpTopic>>priorityForSearch (in category 'accessing') ----- priorityForSearch ^ 0! ----- Method: AbstractHelpTopic>>refresh (in category 'updating') ----- refresh "Do nothing."! ----- Method: AbstractHelpTopic>>subtopics (in category 'accessing') ----- subtopics "Topics can be nested in a tree structure." ^ #()! ----- Method: AbstractHelpTopic>>title (in category 'accessing') ----- title "A brief description of this topic's contents." ^ self contents truncateWithElipsisTo: 20! AbstractHelpTopic subclass: #ClassAPIHelpTopic instanceVariableNames: 'theClass withSubclasses withMethods subclassesAsSeparateTopic' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !ClassAPIHelpTopic commentStamp: 'mt 3/25/2015 15:03' prior: 0! Show comments of a class, their subclasses and methods.! ----- Method: ClassAPIHelpTopic>>contents (in category 'accessing') ----- contents ^ self theClass instanceSide organization classComment! ----- Method: ClassAPIHelpTopic>>icon (in category 'accessing') ----- icon ^ ToolIcons iconNamed: (ToolIcons iconForClass: self theClass name)! ----- Method: ClassAPIHelpTopic>>subclassesAsSeparateTopic (in category 'accessing') ----- subclassesAsSeparateTopic ^ subclassesAsSeparateTopic! ----- Method: ClassAPIHelpTopic>>subclassesAsSeparateTopic: (in category 'accessing') ----- subclassesAsSeparateTopic: aBoolean subclassesAsSeparateTopic := aBoolean.! ----- Method: ClassAPIHelpTopic>>subtopics (in category 'accessing') ----- subtopics ^ (self withMethods ifFalse: [#()] ifTrue: [ { MethodListHelpTopic new theClass: self theClass theNonMetaClass. MethodListHelpTopic new theClass: self theClass theMetaClass }]), (self withSubclasses ifFalse: [#()] ifTrue: [ | topics | topics := self theClass subclasses collect: [:cls | self class new theClass: cls; subclassesAsSeparateTopic: self subclassesAsSeparateTopic; withMethods: self withMethods; withSubclasses: self withSubclasses]. self subclassesAsSeparateTopic ifTrue: [{(HelpTopic named: 'Subclasses') subtopics: topics; yourself}] ifFalse: [topics]])! ----- Method: ClassAPIHelpTopic>>theClass (in category 'accessing') ----- theClass ^ theClass! ----- Method: ClassAPIHelpTopic>>theClass: (in category 'accessing') ----- theClass: aClassDescription theClass := aClassDescription.! ----- Method: ClassAPIHelpTopic>>title (in category 'accessing') ----- title ^ self theClass name! ----- Method: ClassAPIHelpTopic>>withMethods (in category 'accessing') ----- withMethods ^ withMethods ifNil:[false]! ----- Method: ClassAPIHelpTopic>>withMethods: (in category 'accessing') ----- withMethods: aBoolean withMethods := aBoolean.! ----- Method: ClassAPIHelpTopic>>withSubclasses (in category 'accessing') ----- withSubclasses ^ withSubclasses ifNil:[false]! ----- Method: ClassAPIHelpTopic>>withSubclasses: (in category 'accessing') ----- withSubclasses: aBoolean withSubclasses := aBoolean.! AbstractHelpTopic subclass: #ClassBasedHelpTopic instanceVariableNames: 'helpClass subtopics' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !ClassBasedHelpTopic commentStamp: 'mt 3/24/2015 16:28' prior: 0! This kind of topic uses subclasses and methods to encode books and pages.! ----- Method: ClassBasedHelpTopic>>contents (in category 'accessing') ----- contents "A book has no contents. Only its pages do." ^ ''! ----- Method: ClassBasedHelpTopic>>hasSubtopics (in category 'testing') ----- hasSubtopics ^ self helpClass pages notEmpty or: [self helpClass subclasses notEmpty]! ----- Method: ClassBasedHelpTopic>>helpClass (in category 'accessing') ----- helpClass ^ helpClass! ----- Method: ClassBasedHelpTopic>>helpClass: (in category 'accessing') ----- helpClass: aHelpClass helpClass := aHelpClass.! ----- Method: ClassBasedHelpTopic>>icon (in category 'accessing') ----- icon ^ self helpClass icon! ----- Method: ClassBasedHelpTopic>>isEditable (in category 'testing') ----- isEditable ^ true! ----- Method: ClassBasedHelpTopic>>priority (in category 'accessing') ----- priority ^ self helpClass priority! ----- Method: ClassBasedHelpTopic>>refresh (in category 'updating') ----- refresh self updateSubtopics. self changed: #subtopicsUpdated.! ----- Method: ClassBasedHelpTopic>>subtopics (in category 'accessing') ----- subtopics ^ subtopics ifNil: [self updateSubtopics]! ----- Method: ClassBasedHelpTopic>>title (in category 'accessing') ----- title ^ self helpClass bookName! ----- Method: ClassBasedHelpTopic>>updateSubtopics (in category 'updating') ----- updateSubtopics | pages | pages := (self helpClass pages collect: [:pageSelectorOrClassName | (Smalltalk hasClassNamed: pageSelectorOrClassName asString) ifTrue: [Smalltalk classNamed: pageSelectorOrClassName asString] ifFalse: [pageSelectorOrClassName]]) asOrderedCollection. self helpClass subclasses select: [:cls | cls ignore not] thenDo: [:cls | pages addIfNotPresent: cls]. ^ subtopics := pages withIndexCollect: [:pageSelectorOrClass :priority | pageSelectorOrClass isBehavior ifFalse: [(self helpClass perform: pageSelectorOrClass) priority: priority - pages size; key: pageSelectorOrClass; yourself] ifTrue: [pageSelectorOrClass asHelpTopic]]! AbstractHelpTopic subclass: #HelpTopic instanceVariableNames: 'title key icon contents subtopics priority' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !HelpTopic commentStamp: 'mt 3/25/2015 11:27' prior: 0! This is a configurable version of a help topic. You can define its contents, title, icon, and subtopics manually. Help builders make use of this.! ----- Method: HelpTopic class>>named: (in category 'instance creation') ----- named: aString "Create a new instance with given title and empty contents" ^(self new) title: aString; yourself! ----- Method: HelpTopic class>>title:contents: (in category 'instance creation') ----- title: aTitle contents: aText "Create a new instance with given title and content" ^(self new) title: aTitle; contents: aText; yourself. ! ----- Method: HelpTopic class>>title:icon:contents: (in category 'instance creation') ----- title: aTitle icon: anIcon contents: aText "Create a new instance with given title, icon and content" ^(self new) title: aTitle; icon: anIcon; contents: aText; yourself. ! ----- Method: HelpTopic>>addSubtopic: (in category 'accessing') ----- addSubtopic: aTopic "Adds the given topic to the receivers collection of subtopics" self subtopics add: aTopic. self changed: #subtopicAdded with: aTopic. ^aTopic! ----- Method: HelpTopic>>contents (in category 'accessing') ----- contents "Returns the receivers contents" ^ contents! ----- Method: HelpTopic>>contents: (in category 'accessing') ----- contents: anObject "Sets the receivers contents to the given object" contents := anObject! ----- Method: HelpTopic>>defaultTitle (in category 'defaults') ----- defaultTitle "Returns the receivers default title" ^'Unnamed Topic' ! ----- Method: HelpTopic>>icon (in category 'accessing') ----- icon "Returns the receivers icon" ^icon! ----- Method: HelpTopic>>icon: (in category 'accessing') ----- icon: aSymbol "Sets the receivers icon" icon := aSymbol ! ----- Method: HelpTopic>>initialize (in category 'initialize-release') ----- initialize "Initializes the receiver" super initialize. self title: self defaultTitle. self contents: ''.! ----- Method: HelpTopic>>key (in category 'accessing') ----- key ^ key! ----- Method: HelpTopic>>key: (in category 'accessing') ----- key: aSymbol key := aSymbol.! ----- Method: HelpTopic>>priority (in category 'accessing') ----- priority "A hint for tools to influence sort order." ^ priority! ----- Method: HelpTopic>>priority: (in category 'accessing') ----- priority: anInteger priority := anInteger.! ----- Method: HelpTopic>>sortSubtopicsByTitle (in category 'operating') ----- sortSubtopicsByTitle "Sort the subtopics by title" subtopics := SortedCollection withAll: self subtopics ! ----- Method: HelpTopic>>subtopics (in category 'accessing') ----- subtopics "Returns the receivers list of subtopics" subtopics isNil ifTrue: [subtopics := OrderedCollection new]. ^subtopics! ----- Method: HelpTopic>>subtopics: (in category 'accessing') ----- subtopics: aCollection "Sets the receivers subtopics" subtopics := aCollection ! ----- Method: HelpTopic>>title (in category 'accessing') ----- title "Returns the receivers title" ^ title! ----- Method: HelpTopic>>title: (in category 'accessing') ----- title: anObject "Sets the receivers title" title := anObject! AbstractHelpTopic subclass: #HtmlHelpTopic instanceVariableNames: 'url document selectBlock convertBlock subtopicUrls subtopics level' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! ----- Method: HtmlHelpTopic>>contents (in category 'accessing') ----- contents | start end | start := (self document findString: '' startingAt: start) + 1. end := self document findString: '' startingAt: start. start > end ifTrue: [^ self document]. ^ ((self document copyFrom: start to: end - 1) copyReplaceAll: String cr with: '
') asTextFromHtml! ----- Method: HtmlHelpTopic>>convertBlock (in category 'accessing') ----- convertBlock ^ convertBlock ifNil: [ [:aUrl | aUrl] ]! ----- Method: HtmlHelpTopic>>convertBlock: (in category 'accessing') ----- convertBlock: aBlock convertBlock := aBlock.! ----- Method: HtmlHelpTopic>>document (in category 'accessing') ----- document ^ document ifNil: [document := [ (HTTPSocket httpGet: self url accept: 'text/html') contents ] on: Error do: [:err | err printString]]! ----- Method: HtmlHelpTopic>>fetchSubtopics (in category 'caching') ----- fetchSubtopics "If this method is called from another process than the ui process, there will be no progress shown." | updateBlock | updateBlock := [:topic | topic document; subtopicUrls]. Project current uiProcess == Processor activeProcess ifFalse: [self subtopics do: updateBlock] ifTrue: [self subtopics do: updateBlock displayingProgress: [:topic | 'Fetching documents ... ', topic url]].! ----- Method: HtmlHelpTopic>>hasSubtopics (in category 'testing') ----- hasSubtopics ^ self subtopicUrls notEmpty! ----- Method: HtmlHelpTopic>>isSearchable (in category 'testing') ----- isSearchable ^ self level < 2! ----- Method: HtmlHelpTopic>>level (in category 'accessing') ----- level ^ level ifNil: [level := 1]! ----- Method: HtmlHelpTopic>>level: (in category 'accessing') ----- level: anInteger level := anInteger.! ----- Method: HtmlHelpTopic>>priorityForSearch (in category 'accessing') ----- priorityForSearch ^ 999 "very late"! ----- Method: HtmlHelpTopic>>refresh (in category 'caching') ----- refresh "Re-fetch document and all referenced urls." document := nil. subtopics := nil. self changed: #contents. "See #contents. It is based on document." self changed: #subtopics.! ----- Method: HtmlHelpTopic>>selectBlock (in category 'accessing') ----- selectBlock ^ selectBlock ifNil: [ [:aUrl | true] ]! ----- Method: HtmlHelpTopic>>selectBlock: (in category 'accessing') ----- selectBlock: aBlock "Which urls should be followed?" selectBlock := aBlock.! ----- Method: HtmlHelpTopic>>subtopicUrls (in category 'accessing') ----- subtopicUrls ^ subtopicUrls ifNil: [ | start end | subtopicUrls := OrderedCollection new. start := self document findString: ' 0] whileTrue: [ start := self document findString: '"' startingAt: start. end := self document findString: '"' startingAt: start+1. subtopicUrls addIfNotPresent: (self document copyFrom: start+1 to: end-1). start := self document findString: ' 0 ifTrue: [start := self document findString: 'href' startingAt: start]]. subtopicUrls := subtopicUrls select: self selectBlock thenCollect: self convertBlock. subtopicUrls]! ----- Method: HtmlHelpTopic>>subtopics (in category 'accessing') ----- subtopics | start end urls | subtopics ifNotNil: [^ subtopics]. urls := OrderedCollection new. start := self document findString: ' 0] whileTrue: [ start := self document findString: 'href' startingAt: start. start := (self document findString: '"' startingAt: start) + 1. end := self document findString: '"' startingAt: start. urls addIfNotPresent: (self document copyFrom: start to: end - 1). start := self document findString: '>title (in category 'accessing') ----- title | start end | start := (self document findString: '' startingAt: start) + 1. end := self document findString: '' startingAt: start. start > end ifTrue: [^ self url asUrl authority]. ^ self document copyFrom: start to: end - 1! ----- Method: HtmlHelpTopic>>url (in category 'accessing') ----- url ^ url! ----- Method: HtmlHelpTopic>>url: (in category 'accessing') ----- url: aString url := aString.! AbstractHelpTopic subclass: #MethodListHelpTopic instanceVariableNames: 'theClass' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! ----- Method: MethodListHelpTopic>>contents (in category 'accessing') ----- contents ^ (String streamContents: [ :stream | self theClass selectors sort do: [ :selector | stream nextPutAll: self theClass name; nextPutAll: '>>'; nextPutAll: selector asString; cr; nextPutAll: ( (self theClass commentsAt: selector) at: 1 ifAbsent: [ '-' ]); cr; cr ] ])! ----- Method: MethodListHelpTopic>>icon (in category 'accessing') ----- icon ^ HelpIcons iconNamed: #pageIcon! ----- Method: MethodListHelpTopic>>priority (in category 'accessing') ----- priority ^ -999! ----- Method: MethodListHelpTopic>>theClass (in category 'accessing') ----- theClass ^ theClass! ----- Method: MethodListHelpTopic>>theClass: (in category 'accessing') ----- theClass: aClassOrMetaClass theClass := aClassOrMetaClass.! ----- Method: MethodListHelpTopic>>title (in category 'accessing') ----- title ^ self theClass isMeta ifTrue: ['Class side'] ifFalse: ['Instance side']! AbstractHelpTopic subclass: #PackageAPIHelpTopic instanceVariableNames: 'packageName' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !PackageAPIHelpTopic commentStamp: 'mt 3/25/2015 15:02' prior: 0! List all classes and their method comments. No subclasses.! ----- Method: PackageAPIHelpTopic>>contents (in category 'accessing') ----- contents ^ ''! ----- Method: PackageAPIHelpTopic>>hasSubtopics (in category 'testing') ----- hasSubtopics ^ SystemOrganization categories anySatisfy: [:cat | (cat beginsWith: self packageName) and: [(SystemOrganization listAtCategoryNamed: cat) notEmpty]]! ----- Method: PackageAPIHelpTopic>>packageName (in category 'accessing') ----- packageName ^ packageName! ----- Method: PackageAPIHelpTopic>>packageName: (in category 'accessing') ----- packageName: aString packageName := aString.! ----- Method: PackageAPIHelpTopic>>subtopics (in category 'accessing') ----- subtopics ^ ((PackageInfo named: self packageName) classes sorted: [:cl1 :cl2 | cl1 name < cl2 name]) collect: [:class | ClassAPIHelpTopic new theClass: class; withSubclasses: false; withMethods: true]! ----- Method: PackageAPIHelpTopic>>title (in category 'accessing') ----- title ^ self packageName! AbstractHelpTopic subclass: #SearchTopic instanceVariableNames: 'term process results resultText topicsToSearch mutex updatePending' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! ----- Method: SearchTopic>><= (in category 'comparing') ----- <= anotherHelpTopic ^ true "Keep insertion order in parent topic."! ----- Method: SearchTopic>>contents (in category 'accessing') ----- contents ^ resultText ifNil: [self updateResultText]! ----- Method: SearchTopic>>find:in:results: (in category 'as yet unclassified') ----- find: term in: path results: results | resultTemplate c topic | topic := path last. resultTemplate := Array new: 5. (topic title asString findString: term startingAt: 1 caseSensitive: false) in: [:index | index > 0 ifTrue: [resultTemplate at: 2 put: (index to: index + term size)]]. ((c := topic contents asString withSqueakLineEndings) findString: term startingAt: 1 caseSensitive: false) in: [:index | index > 0 ifTrue: [ | leadingContext trailingContext i | leadingContext := 0. trailingContext := 0. i := index. [i notNil] whileTrue: [ (leadingContext = 2 or: [i = 1]) ifTrue: [ leadingContext := i = 1 ifTrue: [i] ifFalse: [i+1]. i := nil] ifFalse: [ ((c at: i) = Character cr) ifTrue: [ leadingContext := leadingContext + 1]. i := i - 1] ]. i := index + term size. [i notNil] whileTrue: [ (trailingContext = 2 or: [i = c size]) ifTrue: [ trailingContext := i = c size ifTrue: [i] ifFalse: [i-1]. i := nil] ifFalse: [ ((c at: i) = Character cr) ifTrue: [ trailingContext := trailingContext + 1]. i := i + 1] ]. resultTemplate at: 1 put: path; at: 3 put: (index - leadingContext + 1 to: index - leadingContext + term size); at: 4 put: (c copyFrom: leadingContext to: trailingContext); at: 5 put: leadingContext. self mutex critical: [ results add: resultTemplate ]. self triggerUpdateContents. ] ]. topic isSearchable ifTrue: [ topic subtopics do: [:t | self find: term in: path, {t} results: results]].! ----- Method: SearchTopic>>mutex (in category 'as yet unclassified') ----- mutex ^ mutex ifNil: [mutex := Mutex new]! ----- Method: SearchTopic>>printResultEntry: (in category 'as yet unclassified') ----- printResultEntry: entry | resultEntry topic | resultEntry := '' asText. topic := entry first last. entry second notNil ifFalse: [resultEntry append: ( (topic title) asText addAttribute: TextEmphasis bold)] ifTrue: [resultEntry append: ( (topic title) asText addAttribute: TextEmphasis bold; addAttribute: (TextColor color: Color green muchDarker) from: entry second first to: entry second last)]. resultEntry append: (' (open topic)' asText addAttribute: (PluggableTextAttribute evalBlock: [self changed: #searchResultSelected with: entry first])). resultEntry append: String cr. entry fourth in: [:contents | | text | text := contents asText. text addAttribute: (TextColor color: Color green muchDarker) from: entry third first to: entry third last; addAttribute: TextEmphasis bold from: entry third first to: entry third last. resultEntry append: text withBlanksTrimmed; append: '\\' withCRs. ]. ^ resultEntry! ----- Method: SearchTopic>>startSearch (in category 'as yet unclassified') ----- startSearch self stopSearch. results := OrderedCollection new. self topicsToSearch ifEmpty: [ self changed: #contents. ^ self]. process := [ (self topicsToSearch sorted: [:t1 :t2 | t1 priorityForSearch <= t2 priorityForSearch]) do: [:topic | | nestedResults | nestedResults := OrderedCollection new. self mutex critical: [results add: topic -> nestedResults]. self find: self term in: {topic} results: nestedResults]. results add: 'Search finished.'. self triggerUpdateContents. ] forkAt: 35.! ----- Method: SearchTopic>>stopSearch (in category 'as yet unclassified') ----- stopSearch process ifNotNil: #terminate. process := nil.! ----- Method: SearchTopic>>term (in category 'accessing') ----- term ^ term! ----- Method: SearchTopic>>term: (in category 'accessing') ----- term: aString term := aString.! ----- Method: SearchTopic>>title (in category 'accessing') ----- title ^ '''', self term, ''''! ----- Method: SearchTopic>>topicsToSearch (in category 'accessing') ----- topicsToSearch ^ topicsToSearch ifNil: [#()]! ----- Method: SearchTopic>>topicsToSearch: (in category 'accessing') ----- topicsToSearch: someTopics topicsToSearch := someTopics.! ----- Method: SearchTopic>>triggerUpdateContents (in category 'as yet unclassified') ----- triggerUpdateContents self mutex critical: [ updatePending == true ifFalse: [ updatePending := true. Project current addDeferredUIMessage: [ActiveWorld addAlarm: #updateContents withArguments: #() for: self at: Time millisecondClockValue + 250] ] ]. ! ----- Method: SearchTopic>>updateContents (in category 'as yet unclassified') ----- updateContents self mutex critical: [ updatePending := false ]. resultText := nil. self changed: #contents with: self.! ----- Method: SearchTopic>>updateResultText (in category 'as yet unclassified') ----- updateResultText resultText := '' asText. self mutex critical: [ results ifNil: [^ resultText]. results do: [:topicToResult | topicToResult isString ifTrue: [resultText append: ( (topicToResult, String cr) asText addAttribute: (TextColor color: (Color gray: 0.7)); yourself)] ifFalse: [ resultText append: ( ('\----- Matches found in ''', topicToResult key title, ''' -----\\') withCRs asText addAttribute: (TextColor color: (Color gray: 0.7))). topicToResult value do: [:entry | resultText append: (self printResultEntry: entry)] ]]]. ^ resultText! Model subclass: #HelpBrowser instanceVariableNames: 'rootTopic currentTopic currentParentTopic result searchTopic topicPath toplevelTopics oldTopic' classVariableNames: 'DefaultHelpBrowser' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpBrowser commentStamp: 'tbn 3/8/2010 09:33' prior: 0! A HelpBrowser is used to display a hierarchy of help topics and their contents. Instance Variables rootTopic: window: treeMorph: contentMorph: rootTopic - xxxxx window - xxxxx treeMorph - xxxxx contentMorph - xxxxx ! ----- Method: HelpBrowser class>>defaultHelpBrowser (in category 'accessing') ----- defaultHelpBrowser DefaultHelpBrowser isNil ifTrue: [DefaultHelpBrowser := self]. ^DefaultHelpBrowser ! ----- Method: HelpBrowser class>>defaultHelpBrowser: (in category 'accessing') ----- defaultHelpBrowser: aClass "Use a new help browser implementation" DefaultHelpBrowser := aClass ! ----- Method: HelpBrowser class>>initialize (in category 'class initialization') ----- initialize "Initializes the receiver class" TheWorldMenu registerOpenCommand: {'Help Browser'. {self. #open}}. ! ----- Method: HelpBrowser class>>open (in category 'instance creation') ----- open ^self openOn: CustomHelp! ----- Method: HelpBrowser class>>openOn: (in category 'instance creation') ----- openOn: aHelpTopic "Open the receiver on the given help topic or any other object that can be transformed into a help topic by sending #asHelpTopic." ^(self defaultHelpBrowser new) open; rootTopic: aHelpTopic; yourself! ----- Method: HelpBrowser>>accept: (in category 'actions') ----- accept: text "Accept edited text. Compile it into a HelpTopic" | code parent topicClass topicMethod | (self currentParentTopic isNil or: [self currentParentTopic isEditable not]) ifTrue: [^ self inform: 'This help topic cannot be edited.']. parent := self currentParentTopic. topicClass := parent helpClass. topicMethod := self currentTopic key. code := String streamContents:[:s| s nextPutAll: topicMethod. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', topicMethod storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', currentTopic title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. topicClass class compile: code classified: ((topicClass class organization categoryOfElement: topicMethod) ifNil:['pages']). parent refresh. self currentTopic: (parent subtopics detect: [:t | t key = topicMethod]).! ----- Method: HelpBrowser>>buildWith: (in category 'toolbuilder') ----- buildWith: builder | windowSpec treeSpec textSpec searchSpec | windowSpec := builder pluggableWindowSpec new. windowSpec model: self; children: OrderedCollection new; label: #label. searchSpec := builder pluggableInputFieldSpec new. searchSpec model: self; getText: #searchTerm; setText: #searchTerm:; help: 'Search...'; frame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (Preferences standardDefaultTextFont height * 2))). windowSpec children add: searchSpec. treeSpec := builder pluggableTreeSpec new. treeSpec model: self; nodeClass: HelpTopicListItemWrapper; roots: #toplevelTopics; getSelected: #currentTopic; setSelected: #currentTopic:; getSelectedPath: #currentTopicPath; setSelectedParent: #currentParentTopic:; autoDeselect: false; frame: (LayoutFrame fractions: (0@0 corner: 0.3@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)). windowSpec children add: treeSpec. textSpec := builder pluggableTextSpec new. textSpec model: self; getText: #topicContents; setText: #accept:; menu: #codePaneMenu:shifted:; frame: (LayoutFrame fractions: (0.3@0.0 corner: 1@1) offsets: (0@ (Preferences standardDefaultTextFont height * 2) corner: 0@0)). windowSpec children add: textSpec. ^ builder build: windowSpec! ----- Method: HelpBrowser>>codePaneMenu:shifted: (in category 'events') ----- codePaneMenu: aMenu shifted: shifted ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted ! ----- Method: HelpBrowser>>currentParentTopic (in category 'accessing') ----- currentParentTopic ^ currentParentTopic! ----- Method: HelpBrowser>>currentParentTopic: (in category 'accessing') ----- currentParentTopic: aHelpTopic currentParentTopic := aHelpTopic.! ----- Method: HelpBrowser>>currentTopic (in category 'accessing') ----- currentTopic ^ currentTopic! ----- Method: HelpBrowser>>currentTopic: (in category 'accessing') ----- currentTopic: aHelpTopic self currentTopic == aHelpTopic ifTrue: [^ self]. currentTopic := aHelpTopic. topicPath := nil. self changed: #currentTopic. self changed: #topicContents.! ----- Method: HelpBrowser>>currentTopicPath (in category 'accessing') ----- currentTopicPath "Only used for dynamic dispatch. Should be nil or empty on manual evaluation. See #topic:." ^ topicPath ifNil: [#()]! ----- Method: HelpBrowser>>currentTopicPath: (in category 'accessing') ----- currentTopicPath: someTopics "Use the tree structure to select a nested topic." topicPath := someTopics. self changed: #currentTopicPath.! ----- Method: HelpBrowser>>find (in category 'actions') ----- find "Prompt the user for a string to search for, and search the receiver from the current selection onward for it." | reply | reply := UIManager default request: 'Find what? ' initialAnswer: ''. reply size = 0 ifTrue: [ ^ self]. self findStringInHelpTopic: reply ! ----- Method: HelpBrowser>>find: (in category 'actions') ----- find: aString ^SystemNavigation allMethodsSelect: [:method | method hasLiteralSuchThat: [:lit | (lit isString and: [lit isSymbol not]) and: [lit includesSubstring: aString caseSensitive: false]]] localTo: CustomHelp ! ----- Method: HelpBrowser>>findAgain (in category 'actions') ----- findAgain | i | (i := result indexOf: currentTopic) ~= 0 ifTrue: [i = result size ifTrue: [(self confirm: 'Start over?') ifTrue: [i := 1] ifFalse: [^ self]]. self onItemClicked: (result at: i + 1)]! ----- Method: HelpBrowser>>findStringInHelpTopic: (in category 'actions') ----- findStringInHelpTopic: aString result := OrderedCollection new. self inSubtopic: self rootTopic find: aString. result ifNotEmpty: [self topic: result first]. ! ----- Method: HelpBrowser>>inSubtopic:find: (in category 'actions') ----- inSubtopic: aTopic find: aString ((aTopic title asString includesSubstring: aString caseSensitive: false) or: [aTopic contents asString includesSubstring: aString caseSensitive: false]) ifTrue: [result addIfNotPresent: aTopic]. aTopic subtopics do: [:sub | self inSubtopic: sub find: aString]! ----- Method: HelpBrowser>>inTopic:replaceCurrentTopicWith: (in category 'actions') ----- inTopic: parentTopic replaceCurrentTopicWith: aNewTopic parentTopic subtopics do: [ :sub | self inTopic: parentTopic replaceSubtopic: sub with: aNewTopic]! ----- Method: HelpBrowser>>inTopic:replaceSubtopic:with: (in category 'actions') ----- inTopic: parentTopic replaceSubtopic: aTopic with: aNewTopic | i | (aTopic = oldTopic) ifTrue: [ i := parentTopic subtopics indexOf: aTopic. parentTopic subtopics at: i put: aNewTopic. ^self ]. aTopic subtopics do: [ :sub | self inTopic: aTopic replaceSubtopic: sub with: aNewTopic]! ----- Method: HelpBrowser>>label (in category 'accessing - ui') ----- label ^ self rootTopic ifNil: ['Help Browser'] ifNotNil: [:topic | topic title]! ----- Method: HelpBrowser>>menu: (in category 'events') ----- menu: aMenu ^aMenu add: 'find...' translated action: #find. ! ----- Method: HelpBrowser>>open (in category 'ui') ----- open ToolBuilder open: self.! ----- Method: HelpBrowser>>rootTopic (in category 'accessing') ----- rootTopic ^rootTopic! ----- Method: HelpBrowser>>rootTopic: (in category 'accessing') ----- rootTopic: aHelpTopic rootTopic := aHelpTopic asHelpTopic. self toplevelTopics: ((self rootTopic ifNil: [#()] ifNotNil: #subtopics) sorted, {self searchTopic}). self changed: #label.! ----- Method: HelpBrowser>>searchTerm (in category 'searching') ----- searchTerm ^ '' "Reset. Terms are cached in SearchTopic instances."! ----- Method: HelpBrowser>>searchTerm: (in category 'searching') ----- searchTerm: aString "Spawn a new search topic." | topic | topic := self searchTopic subtopics detect: [:t | t term = aString] ifNone: [ | newTopic | newTopic := SearchTopic new term: aString; yourself. self searchTopic addSubtopic: newTopic. newTopic addDependent: self. "Tell me about your updates." newTopic]. "self changed: #searchTerm." "Select results and expand searches node if necessary." self currentTopicPath: {self searchTopic. topic}. self assert: self currentTopic == topic. topic topicsToSearch: self toplevelTopics allButLast; startSearch.! ----- Method: HelpBrowser>>searchTopic (in category 'searching') ----- searchTopic ^ searchTopic ifNil: [searchTopic := HelpTopic new title: 'Search Results'; addDependent: self; yourself]! ----- Method: HelpBrowser>>topicContents (in category 'accessing - ui') ----- topicContents ^ (self currentTopic ifNil: [self rootTopic]) ifNil: '' ifNotNil: #contents! ----- Method: HelpBrowser>>toplevelTopics (in category 'accessing') ----- toplevelTopics ^ toplevelTopics ifNil: [#()]! ----- Method: HelpBrowser>>toplevelTopics: (in category 'accessing') ----- toplevelTopics: someTopics toplevelTopics := someTopics. self changed: #toplevelTopics.! ----- Method: HelpBrowser>>update:with: (in category 'updating') ----- update: aspect with: object aspect == #contents ifTrue: [ object == self currentTopic ifTrue: [self changed: #topicContents]]. aspect == #searchResultSelected ifTrue: [ self currentTopicPath: object].! ----- Method: HelpBrowser>>windowIsClosing (in category 'updating') ----- windowIsClosing super windowIsClosing. self searchTopic subtopics do: [:topic | topic stopSearch].! PluggableListItemWrapper subclass: #HelpTopicListItemWrapper instanceVariableNames: 'parent' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpTopicListItemWrapper commentStamp: 'tbn 3/8/2010 09:30' prior: 0! This class implements a list item wrapper for help topics. Instance Variables ! ----- Method: HelpTopicListItemWrapper class>>with:model:parent: (in category 'as yet unclassified') ----- with: anObject model: aModel parent: aParent ^self new setItem: anObject model: aModel parent: aParent ! ----- Method: HelpTopicListItemWrapper>>asString (in category 'accessing') ----- asString "Returns a string used as a label" ^ self item title! ----- Method: HelpTopicListItemWrapper>>balloonText (in category 'accessing') ----- balloonText "Returns a string used for fly by help" ^self item title! ----- Method: HelpTopicListItemWrapper>>contents (in category 'accessing') ----- contents ^self item subtopics sorted collect: [ :each | HelpTopicListItemWrapper with: each model: self model parent: self] ! ----- Method: HelpTopicListItemWrapper>>hasContents (in category 'accessing') ----- hasContents ^ self item hasSubtopics! ----- Method: HelpTopicListItemWrapper>>icon (in category 'accessing') ----- icon "Either return the icon for the given topic" | symbol | self item icon ifNotNil: [:icon | ^ icon]. symbol := self item hasSubtopics ifTrue: [#bookIcon] ifFalse: [#pageIcon]. ^HelpIcons iconNamed: symbol! ----- Method: HelpTopicListItemWrapper>>item (in category 'accessing') ----- item ^ super item ifNil: [HelpTopic new]! ----- Method: HelpTopicListItemWrapper>>parent (in category 'accessing') ----- parent ^ parent! ----- Method: HelpTopicListItemWrapper>>parent: (in category 'accessing') ----- parent: aWrapper parent := aWrapper.! ----- Method: HelpTopicListItemWrapper>>setItem:model:parent: (in category 'initialization') ----- setItem: anObject model: aModel parent: itemParent self parent: itemParent. self setItem: anObject model: aModel.! ----- Method: HelpTopicListItemWrapper>>update: (in category 'accessing') ----- update: aspect super update: aspect. "Map the domain-specific aspect to a framework-specific one." aspect = #subtopicsUpdated ifTrue: [ self changed: #contents].! ----- Method: HelpTopicListItemWrapper>>update:with: (in category 'accessing') ----- update: aspect with: object super update: aspect with: object. "Map the domain-specific aspect to a framework-specific one." aspect = #subtopicAdded ifTrue: [ self changed: #contents].! Object subclass: #CustomHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Utilities'! !CustomHelp commentStamp: 'tbn 3/29/2010 13:23' prior: 0! This is a common superclass for custom help. Subclasses of this class are automatically included into the system help. By default the informations provided on the receiver class are converted into help topics by a specific builder - here the CustomHelpHelpBuilder. Note that you can provide an own custom builder by overriding the #builder method ! ----- Method: CustomHelp class>>accept:title:contents: (in category 'editing') ----- accept: aSelector title: title contents: text "Accept edited text. Compile it into a HelpTopic" | code | code := String streamContents:[:s| s nextPutAll: aSelector. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', aSelector storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPutWithStyle: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. self class compile: code classified: ((self class organization categoryOfElement: aSelector) ifNil:['pages']). ! ----- Method: CustomHelp class>>asHelpTopic (in category 'converting') ----- asHelpTopic "Convert the receiver to a help topic" ^ ClassBasedHelpTopic new helpClass: self! ----- Method: CustomHelp class>>bookName (in category 'accessing') ----- bookName "Returns the name of the custom help book" ^'Help'! ----- Method: CustomHelp class>>edit: (in category 'editing') ----- edit: aSelector "Open a Workspace on the text in the given selector. When accepted, compile the result as a help topic." | topic window | topic := (self respondsTo: aSelector) ifTrue:[self perform: aSelector] ifFalse:[HelpTopic title: 'Untitled' contents: 'Please edit this topic. To change the topic title, edit the window label.']. window := UIManager default edit: topic contents label: topic title accept: [:text| self accept: aSelector title: window label contents: text]. ! ----- Method: CustomHelp class>>icon (in category 'accessing') ----- icon "Returns an icon used for displaying the custom help book" ^HelpIcons iconNamed: #bookIcon! ----- Method: CustomHelp class>>ignore (in category 'accessing') ----- ignore ^ false! ----- Method: CustomHelp class>>pages (in category 'accessing') ----- pages "Returns a collection of method selectors to return the pages of the custom help book" ^#()! ----- Method: CustomHelp class>>priority (in category 'accessing') ----- priority ^ nil! CustomHelp subclass: #HelpOnHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! !HelpOnHelp commentStamp: 'dtl 11/13/2014 19:20' prior: 0! HelpOnHelp is documentation for the help system! HelpOnHelp subclass: #HelpAPIDocumentation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! !HelpAPIDocumentation commentStamp: 'tbn 4/30/2010 15:12' prior: 0! This class represents the browsable package API help for the help system. Instance Variables ! ----- Method: HelpAPIDocumentation class>>asHelpTopic (in category 'defaults') ----- asHelpTopic ^ (HelpTopic named: self bookName) subtopics: (self packages collect: [:pkgName | PackageAPIHelpTopic new packageName: pkgName]); yourself! ----- Method: HelpAPIDocumentation class>>bookName (in category 'accessing') ----- bookName ^'API Documentation'! ----- Method: HelpAPIDocumentation class>>packages (in category 'accessing') ----- packages ^#('HelpSystem-Core-Model' 'HelpSystem-Core-Utilities' 'HelpSystem-Core-UI')! HelpOnHelp subclass: #HelpHowToHelpTopics instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! ----- Method: HelpHowToHelpTopics class>>bookName (in category 'accessing') ----- bookName ^'Implementation'! ----- Method: HelpHowToHelpTopics class>>overview (in category 'pages') ----- overview ^HelpTopic title: 'Overview' contents: 'THE IMPLEMENTATION The help system typically consists of help books including one or more pages. A book or page is therefore a "topic of interest" providing contents for help to a user. A topic has a title and an icon and is able to have subtopics forming a hierarchy of topics. This simple model is reflected in the class HelpTopic. Since this model forms a hierarchical structure of help topics there is a browser with a tree to display the help contents. This browser is implemented in class HelpBrowser. You can open this browser programmatically using: HelpBrowser open ' ! ----- Method: HelpHowToHelpTopics class>>page1 (in category 'pages') ----- page1 ^HelpTopic title: '1. Simple help topics' contents: 'The help browser usually operates on a hierarchy of help topics with one help topic at the root level. Evaluate the following expression in a workspace to contruct a simple help topic and open it as a root topic in the help browser. |root| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. HelpBrowser openOn: root Note that the help browser displays the contents of our topic in the right page and uses the topics title as the title for the help browser window. '! ----- Method: HelpHowToHelpTopics class>>page2 (in category 'pages') ----- page2 ^HelpTopic title: '2. Forming a hierarchy' contents: 'To form a hierarchy we just have to add new subtopics on our root topic. |root sub1 sub2| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. sub1 := HelpTopic title: ''My first subtopic'' contents: ''First subsection''. sub2 := HelpTopic title: ''My second subtopic'' contents: ''Second subsection''. root addSubtopic: sub1; addSubtopic: sub2. HelpBrowser openOn: root '! ----- Method: HelpHowToHelpTopics class>>page3 (in category 'pages') ----- page3 ^HelpTopic title: '3. Adding icons' contents: 'If you dont like the default icon you can add own custom icons to the topics. See the class HelpIcons for more details. |root sub1 sub2| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. sub1 := HelpTopic title: ''My first subtopic'' contents: ''First subsection''. sub2 := HelpTopic title: ''My second subtopic'' icon: (HelpIcons iconNamed: #packageIcon) contents: ''Second subsection''. root addSubtopic: sub1; addSubtopic: sub2. HelpBrowser openOn: root '! ----- Method: HelpHowToHelpTopics class>>page4 (in category 'pages') ----- page4 ^HelpTopic title: '4. Own help objects' contents: 'You can open this help browser directly on an instance of HelpTopic, but it is more common to open it on any object that understands the message #asHelpTopic. So you can write for instance: HelpBrowser openOn: Integer opening a short API help/system reference on the Integer class. The above expression is the short form for: HelpBrowser openOn: (SystemReference forClass: Integer) If you want you can include the subclasses: HelpBrowser openOn: (SystemReference hierarchyFor: Integer) or even methods HelpBrowser openOn: (SystemReference hierarchyWithMethodsFor: Integer) You can browse the whole system reference documentation using: HelpBrowser openOn: SystemReference But these are only a few examples what we can extract from the system. However - the major goal is NOT an API browser, the idea is to provide a simple architecture to provide browsable help contents depending on the context. For instance it should also be possible to use the help system to provide end user help on any commercial application that is written with the Smalltalk system. ' ! ----- Method: HelpHowToHelpTopics class>>page5 (in category 'pages') ----- page5 ^HelpTopic title: '5. Help sources' contents: 'Since the underlying model is very simple you can easily fill it with nearly any information from different sources. Try this: |topic day url sub| topic := HelpTopic named: ''Last week on Squeak IRC''. 0 to: 7 do: [:index | day := (Date today subtractDays: index) printFormat: #(3 2 1 $. 1 2 2). url := ''http://tunes.org/~nef/logs/squeak/'' , day. sub := HelpTopic title: day contents: (HTTPLoader default retrieveContentsFor: url) contents. topic addSubtopic: sub. ]. HelpBrowser openOn: topic ' ! ----- Method: HelpHowToHelpTopics class>>pages (in category 'accessing') ----- pages ^#(overview page1 page2 page3 page4 page5)! HelpHowToHelpTopics subclass: #HelpHowToHelpTopicsFromCode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! ----- Method: HelpHowToHelpTopicsFromCode class>>bookName (in category 'accessing') ----- bookName ^'Custom help from code'! ----- Method: HelpHowToHelpTopicsFromCode class>>overview (in category 'pages') ----- overview ^HelpTopic title: 'Overview' contents: 'OVERVIEW The help system allows you to provide own books and help texts. You can open the help browser on any object that is able to understand #asHelpTopic. This method returns the root node of the displayed topic hierarchy: HelpBrowser openOn: myObject Typically the object does not convert itself to a help topic structure, usually it dispatches to a builder (see HelpBuilder and subclasses) who does all this. A much more convenient and reproducable way is to implement custom help classes. This allows you to implement and manage your help texts using the standard development and code management tools. These custom help classes are subclasses of "CustomHelp" and are automatically included into the standard help browser. '! ----- Method: HelpHowToHelpTopicsFromCode class>>pages (in category 'accessing') ----- pages ^#(overview step1 step2 step3 step4 step5 step6 step7)! ----- Method: HelpHowToHelpTopicsFromCode class>>step1 (in category 'pages') ----- step1 ^HelpTopic title: 'Step 1 - Create a class for the book' contents: 'STEP 1 - CREATE A CLASS FOR THE BOOK There is a predefined class CustomHelp which you have to subclass for a custom help book to show up as a book in the Help browser: CustomHelp subclass: #MyAppHelp instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''MyApp-Help'' Class methods on this class can reflect pages and if you want to provide nested help books just subclass your own help class to form a hierarchy. Any new subclass of MyAppHelp will then be a new book in your hierarchy. The class category used should end with "-Help" so it is easy to recognize that it includes the help support of your project.' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step2 (in category 'pages') ----- step2 ^HelpTopic title: 'Step 2 - Provide a book name' contents: 'STEP 2 - PROVIDE A BOOK NAME Now implement the class method #bookName to return the name of your help book. bookName ^''My App help'' By implementing this method the system knows how you would like to name your book and uses the given string as a label in the HelpBrowser later.' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step3 (in category 'pages') ----- step3 ^HelpTopic title: 'Step 3 - Implement pages using methods' contents: 'STEP 3 - IMPLEMENT PAGES USING METHODS Implement a page by defining a method that returns an instance of HelpPage defining a page title and a help text displayed in the help browser. firstPage ^HelpTopic title: ''First Page'' contents: ''Hello world'' Define a new method for each page of your book. Please group the pages in a method category called "pages". You can also define an icon for the specific page: secondPage ^HelpTopic title: ''Second Page'' icon: (HelpIcons iconNamed: #packageIcon) contents: ''More to come'' Note: ===== Later we may add support for better help contents than just plain text (markup descriptions, active morphs, ...) ' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step4 (in category 'pages') ----- step4 ^HelpTopic title: 'Step 4 - Defining the page order' contents: 'STEP 4 - DEFINING THE PAGE ORDER By implementing the class method #pages you return a collection of method selectors to define the order in which the pages appear in your book: pages ^#(firstPage secondPage) ' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step5 (in category 'pages') ----- step5 ^HelpTopic title: 'Step 5 - Test your help' contents: 'STEP 5 - TEST YOUR HELP By using HelpBrowser open ' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step6 (in category 'pages') ----- step6 ^HelpTopic title: 'Step 6 - Add more structure' contents: 'STEP 6 - ADD MORE STRUCTURE If you add a new subclass to your custom help class and repeating step 2 to 4 you can profide new substructures (subbooks) since the help books are mapped to the class hierarchy. Example: MyAppHelp subclass: #MyAppTutorial instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''MyApp-Help'' then implement a #bookName, the pages and a #pages method as before on this new class and reopen the help browser. ' ! ----- Method: HelpHowToHelpTopicsFromCode class>>step7 (in category 'pages') ----- step7 ^HelpTopic title: 'Step 7 - Tips and Tricks' contents: 'STEP 7 - TIPS AND TRICKS Tip1: If you implement the #pages method you can also use the name of a custom help class that should be integrated between the specific pages: #pages ^(firstPage MyAppTutorial secondPage) Tip2: You can easily edit the help contents of a page by using the #edit: message. For our example just evaluate: MyAppHelp edit: #firstPage This will open a workspace with the help contents and when you accept it it will be saved back to the help method defining the topic. ' ! ----- Method: HelpOnHelp class>>bookName (in category 'accessing') ----- bookName ^'Help on Help'! ----- Method: HelpOnHelp class>>introduction (in category 'pages') ----- introduction "This method was automatically generated. Edit it using:" "HelpOnHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'WELCOME TO THE HELP SYSTEM The help system is a simple user interface to display help contents to the user. It can be accessed from the world menu using "Tools" -> "Help Browser" or by evaluating ''HelpBrowser open'' in a workspace. There is a predefined mechanism allowing you to have help contents stored as source code using methods in specific help provider classes. This allows you to manage the help texts using the standard development tools. But this is only one possible representation. !!' readStream nextChunkText! ----- Method: HelpOnHelp class>>pages (in category 'accessing') ----- pages ^#(introduction HelpHowToHelpTopics HelpAPIDocumentation)! ----- Method: HelpOnHelp class>>priority (in category 'accessing') ----- priority ^ 9999 "at the bottom"! Object subclass: #HelpBuilder instanceVariableNames: 'topicToBuild rootToBuildFrom' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !HelpBuilder commentStamp: 'tbn 2/12/2010 14:54' prior: 0! This is an utility class that builds the books for a help system. Instance Variables rootTopics: rootTopics - a collection of books ! HelpBuilder subclass: #ClassAPIHelpBuilder instanceVariableNames: 'addSubclasses addMethods subclassesAsSeparateTopic' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !ClassAPIHelpBuilder commentStamp: 'tbn 4/30/2010 15:37' prior: 0! A builder to build the API Help for a class Instance Variables addMethods: addSubclasses: subclassesAsSeparateTopic: addMethods - When true the builder will include method help addSubclasses - When true the builder will recursively go through and add subclasses subclassesAsSeparateTopic - xxxxx ! ----- Method: ClassAPIHelpBuilder class>>buildHierarchicalHelpTopicFrom:withSubclasses:withMethods: (in category 'building') ----- buildHierarchicalHelpTopicFrom: aClass withSubclasses: aBoolean withMethods: anotherBoolean "Start building from the given class" ^(self new) addSubclasses: aBoolean; addMethods: anotherBoolean; rootToBuildFrom: aClass; build; topicToBuild ! ----- Method: ClassAPIHelpBuilder>>addMethods (in category 'accessing') ----- addMethods ^ addMethods! ----- Method: ClassAPIHelpBuilder>>addMethods: (in category 'accessing') ----- addMethods: anObject addMethods := anObject! ----- Method: ClassAPIHelpBuilder>>addSubclasses (in category 'accessing') ----- addSubclasses ^ addSubclasses! ----- Method: ClassAPIHelpBuilder>>addSubclasses: (in category 'accessing') ----- addSubclasses: anObject addSubclasses := anObject! ----- Method: ClassAPIHelpBuilder>>build (in category 'building') ----- build CurrentReadOnlySourceFiles cacheDuring: [ topicToBuild := (HelpTopic named: rootToBuildFrom name). topicToBuild icon: (HelpIcons iconNamed: #pageIcon). topicToBuild contents: rootToBuildFrom comment. addMethods ifTrue: [ self buildSubnodesForMethods ]. addSubclasses ifTrue: [ self buildSubnodesForSubclasses ] ]. ! ----- Method: ClassAPIHelpBuilder>>buildMethodTopicsOn:for: (in category 'private building') ----- buildMethodTopicsOn: topic for: aClass topic contents: (String streamContents: [ :stream | aClass selectors sort do: [ :selector | stream nextPutAll: aClass name; nextPutAll: '>>'; nextPutAll: selector asString; cr; nextPutAll: ( (aClass commentsAt: selector) at: 1 ifAbsent: [ 'Method has no comment.' ]); cr; cr ] ])! ----- Method: ClassAPIHelpBuilder>>buildSubclassTopicFor: (in category 'private building') ----- buildSubclassTopicFor: aSubclass ^(self class new) rootToBuildFrom: aSubclass; addSubclasses: addSubclasses; addMethods: addMethods; subclassesAsSeparateTopic: subclassesAsSeparateTopic; build; topicToBuild ! ----- Method: ClassAPIHelpBuilder>>buildSubnodesForMethods (in category 'private building') ----- buildSubnodesForMethods | instanceSide classSide | instanceSide := HelpTopic named: 'Instance side'. classSide := HelpTopic named: 'Class side'. topicToBuild icon: (HelpIcons iconNamed: #bookIcon). topicToBuild addSubtopic: instanceSide; addSubtopic: classSide. self buildMethodTopicsOn: instanceSide for: rootToBuildFrom. self buildMethodTopicsOn: classSide for: rootToBuildFrom class. ! ----- Method: ClassAPIHelpBuilder>>buildSubnodesForSubclasses (in category 'private building') ----- buildSubnodesForSubclasses | topic | rootToBuildFrom subclasses isEmpty ifTrue: [^self]. topicToBuild icon: (HelpIcons iconNamed: #bookIcon). topic := subclassesAsSeparateTopic ifTrue: [topicToBuild addSubtopic: (HelpTopic named: 'Subclasses')] ifFalse: [topicToBuild ]. rootToBuildFrom subclasses do: [:subclass | topic addSubtopic: (self buildSubclassTopicFor: subclass)]. topic sortSubtopicsByTitle. ! ----- Method: ClassAPIHelpBuilder>>initialize (in category 'initialize-release') ----- initialize "Initializes the receiver" super initialize. addSubclasses := false. addMethods := true. subclassesAsSeparateTopic := true.! ----- Method: ClassAPIHelpBuilder>>subclassesAsSeparateTopic (in category 'accessing') ----- subclassesAsSeparateTopic ^ subclassesAsSeparateTopic! ----- Method: ClassAPIHelpBuilder>>subclassesAsSeparateTopic: (in category 'accessing') ----- subclassesAsSeparateTopic: anObject subclassesAsSeparateTopic := anObject! HelpBuilder subclass: #CustomHelpHelpBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !CustomHelpHelpBuilder commentStamp: 'tbn 3/29/2010 13:30' prior: 0! This builder builds help topics from a help topic description (which is typically stored in a class). The help topic description object has to understand the following messages: #bookName - should return the name of the help book #icon - should return the icon of the help book #key - should return a unique key to identify the book #pages - should return an array of method selectors to call to get the books pages ! ----- Method: CustomHelpHelpBuilder>>build (in category 'building') ----- build "Start building a help topic from a code description" topicToBuild := self createTopicFrom: rootToBuildFrom ! ----- Method: CustomHelpHelpBuilder>>createTopicFrom: (in category 'private') ----- createTopicFrom: aDescription "Create a topic from a description stored on a class. aDescription can specify (via #pages) the name of a class and not only a selector. This allows for hierarchies with 'subtrees in the middle'" |topic page pageClasses | topic := HelpTopic named: aDescription bookName. topic key: aDescription key. topic icon: aDescription icon. pageClasses := Set new. aDescription pages do: [:pageSelectorOrClass| page:= (Smalltalk hasClassNamed: pageSelectorOrClass asString) ifFalse: [aDescription perform: pageSelectorOrClass] ifTrue: [pageClasses add: (Smalltalk classNamed: pageSelectorOrClass asString). (Smalltalk classNamed: pageSelectorOrClass asString) asHelpTopic]. topic addSubtopic: page. ]. ((aDescription subclasses asSet) removeAllFoundIn: pageClasses; yourself) do: [:subclass | topic subtopics add: subclass asHelpTopic ]. ^topic! ----- Method: HelpBuilder class>>buildHelpTopicFrom: (in category 'building') ----- buildHelpTopicFrom: aHelpTopicDescription "Start building from the given help topic description" ^(self new) rootToBuildFrom: aHelpTopicDescription; build; topicToBuild ! ----- Method: HelpBuilder>>build (in category 'building') ----- build self subclassResponsibility ! ----- Method: HelpBuilder>>initialize (in category 'initialize-release') ----- initialize "Initializes the receiver" super initialize. topicToBuild := self topicClass new. ! ----- Method: HelpBuilder>>rootToBuildFrom: (in category 'accessing') ----- rootToBuildFrom: anObject rootToBuildFrom := anObject! ----- Method: HelpBuilder>>topicClass (in category 'private accessing') ----- topicClass ^HelpTopic! ----- Method: HelpBuilder>>topicToBuild (in category 'accessing') ----- topicToBuild ^topicToBuild! HelpBuilder subclass: #PackageAPIHelpBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! ----- Method: PackageAPIHelpBuilder>>build (in category 'building') ----- build |pTopic| topicToBuild := (HelpTopic named: rootToBuildFrom bookName). rootToBuildFrom packages do: [:package| pTopic := HelpTopic named: package. topicToBuild addSubtopic: pTopic. self buildPackageTopic: pTopic. ] ! ----- Method: PackageAPIHelpBuilder>>buildPackageTopic: (in category 'building') ----- buildPackageTopic: pTopic | classTopic classes | classes := (PackageInfo named: pTopic title) classes asSortedCollection: [:cl1 :cl2 | cl1 name < cl2 name]. classes do: [:aClass| classTopic := ClassAPIHelpBuilder buildHierarchicalHelpTopicFrom: aClass withSubclasses: false withMethods: true. pTopic addSubtopic: classTopic ] ! Object subclass: #HelpIcons instanceVariableNames: '' classVariableNames: 'Icons' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpIcons commentStamp: 'tbn 3/8/2010 09:29' prior: 0! This class is used to store help icons for the help browser. Typically one implements a method returning a 12x12 Form instance which should not be called directly. Since the class provides an internal icon cache (so the icons can be reused without creating too many new instances) the icons should be accessed using the #iconNamed: message with the method selector as argument. To create a form from an icon file stored on disk you can use the following code: | image stream | image := ColorForm fromFileNamed: '/path/to/icon.png'. stream := WriteStream with: String new. image storeOn: stream. stream contents inspect.! ----- Method: HelpIcons class>>blankIcon (in category 'private icons') ----- blankIcon ^Form extent: 12 @ 1 depth:8! ----- Method: HelpIcons class>>bookIcon (in category 'private icons') ----- bookIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 284817913 552924404 0 0 0 0 0 0 0 0 0 817149108 3747766882 4287730065 2679749049 549766340 0 0 0 0 0 0 1086110908 4016202338 4287137928 4288914339 4288914339 4289111718 3216290996 1086505666 0 0 0 816754350 4014952271 4287137928 4289309097 4289769648 4289111718 4288453788 4288453788 4288453788 2947658161 0 814846353 4283782485 4287072135 4288059030 4288059030 4288387995 4289243304 4289309097 4287927444 4287598479 2411050421 1081900156 4283585106 4286611584 4287532686 4287532686 4287466893 4287466893 4287401100 4287401100 4287401100 4288716960 2946868645 3211290728 4288651167 4287269514 4287006342 4287006342 4287006342 4286940549 4286940549 4287203721 4289177511 3483213213 281725642 2677183122 4293190884 4292861919 4289177511 4286874756 4286611584 4286611584 4287006342 4289638062 4020084125 549042617 0 282054607 2677643673 4289572269 4293256677 4292796126 4288980132 4287137928 4290164406 4020215711 816754350 0 0 0 0 551082200 2677643673 4289572269 4293256677 4292401368 4289177511 1085584564 0 0 0 0 0 0 0 551213786 2677643673 4288651167 1623244992 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ----- Method: HelpIcons class>>iconNamed: (in category 'accessing') ----- iconNamed: aSymbol ^self icons at: aSymbol ifAbsentPut: [self perform: aSymbol]! ----- Method: HelpIcons class>>icons (in category 'accessing') ----- icons Icons isNil ifTrue: [Icons := Dictionary new]. ^Icons! ----- Method: HelpIcons class>>packageIcon (in category 'private icons') ----- packageIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 1075649821 3744937783 3208395836 807016986 0 0 0 0 0 0 537857807 2939368243 4283256141 4284045657 4284572001 4284111450 2671524924 269488144 0 0 0 2150575919 4014820685 4284111450 4284374622 4284769380 4285098345 4285295724 4286216826 4017057647 1883456323 0 1076505130 4283848278 4284769380 4284966759 4285624689 4285690482 4285887861 4286611584 4287269514 4287861651 4287269514 1074597133 1076965681 4283914071 4283848278 4285953654 4286216826 4286414205 4286940549 4287466893 4287335307 4286808963 4286743170 1074399754 1077163060 4284637794 4284045657 4284835173 4285887861 4287269514 4287335307 4286282619 4286216826 4286874756 4287006342 1074465547 1077294646 4284835173 4284703587 4285361517 4285624689 4286414205 4285624689 4286085240 4286677377 4287269514 4287401100 1074465547 1077426232 4285098345 4285032552 4286019447 4285822068 4286743170 4286348412 4286677377 4287203721 4287730065 4287795858 1074531340 1077492025 4285229931 4285427310 4286808963 4286216826 4287137928 4287072135 4287401100 4287795858 4288256409 4288190616 1074531340 269356558 2672051268 4285493103 4287598479 4286940549 4287532686 4287795858 4287993237 4288387995 4287006342 2404668500 268501249 0 0 1075912993 3479726184 4287598479 4287927444 4288453788 4287993237 2943118444 539371046 0 0 0 0 0 0 1615086660 4017781370 3749148535 1078347334 0 0 0 0) offset: 0@0)! ----- Method: HelpIcons class>>pageIcon (in category 'private icons') ----- pageIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 221196079 1366981242 1366915449 1366915449 1366849656 1366783863 1128876361 33554432 0 0 0 0 726552142 4294309365 4294243572 4294111986 4294046193 4293914607 4292861919 2843705215 319885585 0 0 0 726551886 4294177779 4294111986 4293980400 4293914607 4293848814 4293717228 4292138196 3734147730 269619730 0 0 726486349 4294046193 4293980400 4293914607 4293783021 4293717228 4293585642 4293454056 4291085508 639705377 0 0 726420557 4293980400 4293848814 4293783021 4293651435 4293585642 4293519849 4293388263 4292993505 640034342 0 0 726420556 4293848814 4293717228 4293651435 4293585642 4293454056 4293388263 4293256677 4293190884 623322919 0 0 726354764 4293717228 4293651435 4293519849 4293454056 4293322470 4293256677 4293125091 4293059298 623257126 0 0 726354507 4293585642 4293519849 4293388263 4293322470 4293190884 4293125091 4293059298 4292993505 623191333 0 0 726288970 4293454056 4293388263 4293256677 4293190884 4293125091 4292993505 4292993505 4292993505 623191333 0 0 726223178 4293322470 4293256677 4293190884 4293059298 4292993505 4292993505 4292993505 4292993505 623191333 0 0 726223177 4293256677 4293125091 4293059298 4292993505 4292993505 4292993505 4292993505 4292993505 623191333 0 0 490092087 3080033685 3079967892 3079967892 3079967892 3079967892 3079967892 3079967892 3079967892 454629657 0) offset: 0@0)! ----- Method: HelpIcons class>>refreshIcon (in category 'private icons') ----- refreshIcon ^(Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 895969127 526080859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1884706390 4168710521 2288675434 271330348 0 0 0 0 0 0 0 0 0 828465505 2609087363 3615917702 4269439610 4285887861 4285624689 3899156584 1766607948 67569415 0 0 0 0 0 50529027 2306242166 4237069452 4286940549 4286611584 4286282619 4285887861 4285558896 4285229931 4268189543 2235514687 0 0 0 0 0 2590862701 4287598479 4287269514 4270097540 3329652342 3312217196 4285887861 4285558896 3345179491 1011567435 0 0 0 0 0 1263423054 4287532686 4287532686 3867378563 1096835168 0 1885166941 3681579120 1549227863 50923785 0 0 0 0 0 0 3061545851 4287795858 4236937866 811951461 0 0 641547581 137441585 0 0 0 0 0 0 0 34936085 4102720138 4287795858 3011016824 0 0 0 0 0 0 0 0 0 0 0 0 272317243 4287861651 4287795858 2489607268 0 0 0 0 0 0 0 0 68095759 0 0 0 204682035 4287730065 4287795858 2658432116 0 0 0 0 0 0 0 34014983 3965146967 4283979864 3125694030 0 0 3767044232 4287795858 3884287365 137244206 0 0 0 0 0 0 1129863256 4284769380 4284506208 2739423304 0 0 2189459584 4287795858 4287532686 2541123190 16843009 0 0 0 0 305805882 3597166696 4284703587 4250885983 910114623 0 0 273698896 3834218889 4287532686 4287335307 3094442353 1094532413 101255433 286199567 1582124365 3731318631 4284966759 4284703587 2689946965 0 0 0 0 879126118 3985082247 4287269514 4286940549 4286611584 4285624689 4285558896 4285624689 4285229931 4284966759 3227212635 220998700 0 0 0 0 0 509698401 2977659771 4286743170 4286545791 4286282619 4285887861 4285558896 4100417383 2170116441 103295016 0 0 0 0 0 0 0 0 575820370 1734895720 2121298032 2037017194 1448564567 255013683 0 0 0 0 0) offset: 0@0)! Object subclass: #SystemReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Utilities'! !SystemReference commentStamp: 'tbn 4/30/2010 15:35' prior: 0! This class defines the full reference help for the system. (contents for the full API Help). Just run "HelpBrowser openOn: SystemReference". ! ----- Method: SystemReference class>>all (in category 'help topic creation') ----- all "HelpBrowser openOn: self all " ^(ClassAPIHelpTopic new) theClass: ProtoObject; withSubclasses: true; withMethods: true; subclassesAsSeparateTopic: false! ----- Method: SystemReference class>>asHelpTopic (in category 'help topic creation') ----- asHelpTopic "HelpBrowser openOn: SystemReference" ^self hierarchyFor: ProtoObject ! ----- Method: SystemReference class>>forClass: (in category 'help topic creation') ----- forClass: aClass |root topic | root := HelpTopic named: 'System reference for ', aClass name. topic := ClassAPIHelpTopic new theClass: aClass; withSubclasses: true; withMethods: true; subclassesAsSeparateTopic: false. root addSubtopic: topic. ^root! ----- Method: SystemReference class>>hierarchyFor: (in category 'help topic creation') ----- hierarchyFor: aClass | root topic | root := HelpTopic named: 'System reference for ', aClass name. topic := (ClassAPIHelpTopic new) theClass: aClass; withSubclasses: true; withMethods: false; subclassesAsSeparateTopic: false. root addSubtopic: topic. ^ root! ----- Method: SystemReference class>>hierarchyWithMethodsFor: (in category 'help topic creation') ----- hierarchyWithMethodsFor: aClass | root topic | root := HelpTopic named: 'System reference for ', aClass name. topic := (ClassAPIHelpTopic new) theClass: aClass; withSubclasses: true; withMethods: true; subclassesAsSeparateTopic: true. root addSubtopic: topic. ^ root! ----- Method: Class>>asHelpTopic (in category '*HelpSystem-Core') ----- asHelpTopic ^SystemReference forClass: self! From commits at source.squeak.org Fri Jun 5 20:18:54 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:19:02 2015 Subject: [squeak-dev] Squeak 4.6: SUnitTools-mt.3.mcz Message-ID: Chris Muller uploaded a new version of SUnitTools to project Squeak 4.6: http://source.squeak.org/squeak46/SUnitTools-mt.3.mcz ==================== Summary ==================== Name: SUnitTools-mt.3 Author: mt Time: 19 April 2015, 7:21:55.82 am UUID: c2d3c452-b6ad-3b4a-ab7e-4b5f750648c0 Ancestors: SUnitTools-topa.2 Moved test for being a test-class to SUnit. ==================== Snapshot ==================== ----- Method: StringHolder>>hasClassWithTestsSelected (in category '*SUnitTools-testing') ----- hasClassWithTestsSelected ^ self selectedClass ifNil: [false] ifNotNil: [:cls | cls isTestClass and: [cls isAbstract not]]! ----- Method: Browser>>hasSystemCategoryWithTestsSelected (in category '*SUnitTools-system category functions') ----- hasSystemCategoryWithTestsSelected (systemOrganizer listAtCategoryNamed: (self selectedSystemCategory ifNil: [^ false])) detect: [:name | self class environment at: name ifPresent: [:cls | cls isTestClass and: [cls isAbstract not]] ifAbsent: [false]] ifNone: [^ false]. ^ true ! ----- Method: Browser>>testRunTests (in category '*SUnitTools-class list functions') ----- testRunTests self testRunSuite: self selectedClass suite. self changed: #classList. self changed: #messageList.! ----- Method: Browser>>testRunTestsCategory (in category '*SUnitTools-system category functions') ----- testRunTestsCategory | suite | suite :=TestSuite new. ((systemOrganizer listAtCategoryNamed: self selectedSystemCategory) collect: [:each | self class environment at: each]) select: [:each | each isTestClass and: [each isAbstract not]] thenDo: [:each | each addToSuiteFromSelectors: suite]. self testRunSuite: suite. self changed: #classList. self changed: #messageList.! ----- Method: Browser>>testsClassListMenu: (in category '*SUnitTools-menus') ----- testsClassListMenu: aMenu self hasClassWithTestsSelected ifFalse: [^ aMenu]. ^ aMenu addList: #( - ('run all tests' testRunTests)); yourself! ----- Method: Browser>>testsSystemCategoryMenu: (in category '*SUnitTools-menus') ----- testsSystemCategoryMenu: aMenu self hasSystemCategoryWithTestsSelected ifFalse: [^ aMenu]. ^ aMenu addList: #( - ('run all tests' testRunTestsCategory)); yourself! ----- Method: CodeHolder>>testBinarySelectorNames (in category '*SUnitTools-running') ----- testBinarySelectorNames ^ IdentityDictionary newFromPairs: #( #& 'conjunction' #| 'disjunction' #==> 'implication' #* 'multiply' #+ 'add' #- 'subtract' #/ 'divide' #// 'remainder' #\\ 'modulo' #<< 'shiftLeft' #>> 'shiftRight' #= 'equality' #== 'identity' #~= 'difference' #~~ 'mismatch' #< 'lessThan' #<= 'lessOrEqualThan' #> 'greaterThan' #>= 'greaterOrEqualThan' #<=> 'spaceshipOperator' #@ 'at' #, 'concatenation' #-> 'association' #=> 'binding' ) ! ----- Method: CodeHolder>>testBrowseClassNamed:possibleMessageNamed: (in category '*SUnitTools-running') ----- testBrowseClassNamed: aClassName possibleMessageNamed: aMessageName | cls selector | (self class environment hasClassNamed: aClassName) ifFalse: ["no dice" ^ self]. cls := self class environment classNamed: aClassName. (aMessageName notNil and: [cls includesLocalSelector: (selector := aMessageName asSymbol)]) ifTrue: [ToolSet browse: cls selector: selector] ifFalse: [ToolSet browseClass: cls].! ----- Method: CodeHolder>>testDebugTest (in category '*SUnitTools-message list functions') ----- testDebugTest | case selector cls | cls := self selectedClass ifNil: [^ self]. selector := self selectedMessageName ifNil: [^ self]. case := cls selector: selector. case debugAsFailure.! ----- Method: CodeHolder>>testFindTest (in category '*SUnitTools-running') ----- testFindTest | cls destClassName destMessage | cls := self selectedClass ifNil: [^ self]. cls isTestClass ifTrue: [" already there " ^ self]. destClassName := cls name asString, 'Test'. destMessage := self selectedMessageName ifNotNil: [:name | self testSelectorFrom: name]. self testBrowseClassNamed: destClassName possibleMessageNamed: destMessage ! ----- Method: CodeHolder>>testFindTested (in category '*SUnitTools-running') ----- testFindTested | cls destClassName destMessage | cls := self selectedClass ifNil: [^ self]. cls isTestClass ifFalse: [" already there " ^ self]. destClassName := (cls name asString endsWith: 'Test') ifTrue: [cls name asString allButLast: 4] ifFalse: [^ self]. destMessage := self selectedMessageName ifNotNil: [:selector | | messageName | messageName := selector asString. (messageName beginsWith: 'test') "operate on test methods only" ifTrue: [ (self class environment classNamed: destClassName) ifNotNil: [:destClass | destClass selectors detect: [:destSelector | (self testSelectorFrom: destSelector) = messageName] ifNone: [nil]]] ifFalse: [nil]]. self testBrowseClassNamed: destClassName possibleMessageNamed: destMessage ! ----- Method: CodeHolder>>testRunSuite: (in category '*SUnitTools-running') ----- testRunSuite: suite | result | result := suite run. (result respondsTo: #dispatchResultsIntoHistory) ifTrue: [result dispatchResultsIntoHistory]. result hasPassed ifTrue: [^ self]. (result defects size = 1 ifTrue: [result defects anyOne] ifFalse: [UIManager default chooseFrom: (result defects collect: [:each | each class name , '>>' , each selector printString]) values: result defects title: ('{1} passes, {2} failures, {3} errors\\Debug a failure or error?' format: { result runCount . result failureCount . result errorCount}) withCRs] ) ifNotNil: [:defect | defect debug]. ! ----- Method: CodeHolder>>testRunTest (in category '*SUnitTools-message list functions') ----- testRunTest | suite | suite := self selectedClass selector: self selectedMessageName. self testRunSuite: suite. self changed: #messageList.! ----- Method: CodeHolder>>testSelectorFrom: (in category '*SUnitTools-running') ----- testSelectorFrom: aSelector | name | name := aSelector isBinary ifTrue: [self testBinarySelectorNames at: aSelector ifAbsent: [^ nil]] ifFalse: [aSelector asString]. ^ String streamContents: [:stream | stream nextPutAll: 'test'. (name findTokens: $:) do: [:each | stream nextPutAll: (each capitalized select: [:char | char isAlphaNumeric])]]! ----- Method: CodeHolder>>testsMessageListMenu: (in category '*SUnitTools-menus') ----- testsMessageListMenu: aMenu (self selectedClass isTestClass and: [self selectedClass isAbstract not and: [self selectedClass allTestSelectors includes: self selectedMessageName]]) ifFalse: [^ aMenu]. ^ aMenu addList: #( - ('run test' testRunTest) ('debug test' testDebugTest)); yourself! ----- Method: CodeHolder>>testsTestFindingMenu: (in category '*SUnitTools-menus') ----- testsTestFindingMenu: aMenu ^ self hasClassWithTestsSelected ifTrue: [aMenu add: 'find tested item' action: #testFindTested; yourself] ifFalse: [aMenu add: 'find test case' action: #testFindTest; yourself] ! ----- Method: TestCase class>>toolIcon (in category '*SUnitTools-icons') ----- toolIcon | classHistory | self isAbstract ifTrue: [^ super toolIcon]. classHistory := TestResult historyFor: self. (classHistory at: #errors) ifNotEmpty: [^ #testRed]. (classHistory at: #failures) ifNotEmpty: [^ #testOrange]. (classHistory at: #passed) ifNotEmpty: [ ^ #testGreen]. ^ #testGray! ----- Method: TestCase class>>toolIconSelector: (in category '*SUnitTools-icons') ----- toolIconSelector: aSelector (self isMeta or: [self isAbstract or: [ (self allTestSelectors includes: aSelector) not]]) ifTrue: [^ super toolIconSelector: aSelector]. (self methodRaisedError: aSelector) ifTrue: [^ #testRed]. (self methodFailed: aSelector) ifTrue: [^ #testOrange]. (self methodPassed: aSelector) ifTrue: [^ #testGreen]. ^ #testGray! ----- Method: ToolIcons class>>testGray (in category '*SUnitTools-icons') ----- testGray ^ Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294177779 4291217094 4288585374 4288453788 4290953922 4294111986 0 0 0 0 0 0 4291217094 4291151301 4292796126 4292532954 4290690750 4290624957 0 0 0 0 0 0 4288585374 4292730333 4290953922 4290427578 4291414473 4287466893 0 0 0 0 0 0 4288387995 4292203989 4290493371 4290164406 4291019715 4287072135 0 0 0 0 0 0 4290822336 4290624957 4291414473 4291019715 4290230199 4289835441 0 0 0 0 0 0 4294111986 4290493371 4287269514 4286940549 4289769648 4293848814 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ----- Method: ToolIcons class>>testGreen (in category '*SUnitTools-icons') ----- testGreen ^ Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4293720299 4288666780 4284466010 4284465241 4288599706 4293654250 0 0 0 0 0 0 4288666780 4288403095 4290962113 4290502586 4288007314 4288401048 0 0 0 0 0 0 4284465754 4290830784 4288008853 4287220872 4288992418 4283999824 0 0 0 0 0 0 4284398936 4290108596 4287351946 4286958211 4288532634 4283800910 0 0 0 0 0 0 4288533401 4288007057 4288926881 4288401561 4287677068 4288133778 0 0 0 0 0 0 4293653994 4288400279 4283867471 4283734348 4288067729 4293521384 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ----- Method: ToolIcons class>>testOrange (in category '*SUnitTools-icons') ----- testOrange ^ Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294964456 4294953101 4294943038 4294942778 4294951813 4294963941 0 0 0 0 0 0 4294953101 4294952588 4294959549 4294958774 4294951038 4294688127 0 0 0 0 0 0 4294943293 4294959548 4294953862 4294951029 4294954132 4293888298 0 0 0 0 0 0 4294941751 4294957228 4294951287 4294949998 4294952328 4293165354 0 0 0 0 0 0 4294951298 4294950267 4294954131 4294952583 4294948207 4293110399 0 0 0 0 0 0 4294898405 4294424959 4293559850 4292902442 4292979327 4294438117 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ----- Method: ToolIcons class>>testRed (in category '*SUnitTools-icons') ----- testRed ^ Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294960869 4294935167 4294716714 4294389034 4294344831 4294764005 0 0 0 0 0 0 4294935167 4294803840 4294687929 4294620593 4293950845 4293623680 0 0 0 0 0 0 4294585642 4294687928 4294477438 4294276206 4294284433 4292028973 0 0 0 0 0 0 4294061098 4294487209 4294276976 4294208615 4294150278 4291242543 0 0 0 0 0 0 4294082687 4293819516 4294284176 4294150277 4293163129 4291854213 0 0 0 0 0 0 4294698469 4293296000 4291635758 4290914863 4291657605 4294174183 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! From commits at source.squeak.org Fri Jun 5 20:19:10 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:19:11 2015 Subject: [squeak-dev] Squeak 4.6: PackageInfo-Base-nice.68.mcz Message-ID: Chris Muller uploaded a new version of PackageInfo-Base to project Squeak 4.6: http://source.squeak.org/squeak46/PackageInfo-Base-nice.68.mcz ==================== Summary ==================== Name: PackageInfo-Base-nice.68 Author: nice Time: 17 December 2013, 11:49:21.474 pm UUID: b6669527-9a35-4783-a64f-8f2af97e330b Ancestors: PackageInfo-Base-fbs.67 No need to check if some class selectors are doIt because doIt are no longer installed in method dictionaries. ==================== Snapshot ==================== (PackageInfo named: 'PackageInfo-Base') preamble: '"below, add code to be run before the loading of this package" PackageOrganizer default unregisterPackageNamed: ''PackageInfo''; unregisterPackageNamed: ''ToolBuilder''; unregisterPackageNamed: ''Morphic-TrueType'''! SystemOrganization addCategory: #'PackageInfo-Base'! ----- Method: String>>escapeEntities (in category '*packageinfo-base') ----- escapeEntities ^ self species streamContents: [:s | self do: [:c | s nextPutAll: c escapeEntities]] ! ----- Method: Character>>escapeEntities (in category '*packageinfo-base') ----- escapeEntities #($< '<' $> '>' $& '&') pairsDo: [:k :v | self = k ifTrue: [^ v]]. ^ String with: self! Object subclass: #PackageInfo instanceVariableNames: 'packageName methodCategoryPrefix preamble postscript preambleOfRemoval postscriptOfRemoval' classVariableNames: '' poolDictionaries: '' category: 'PackageInfo-Base'! PackageInfo class instanceVariableNames: 'default'! !PackageInfo commentStamp: 'bf 7/28/2012 14:11' prior: 0! PackageInfo is used by the system to figure out which classes and methods belong to which package. By default, class categories and method categories are matched against my packageName, but subclasses could override this behavior. For an interesting use of PackageInfo subclasses have a look at OMeta2. It presents the same code base as two different packages, one using decompiled code for bootstrapping, the other using the actual OMeta syntax.! PackageInfo class instanceVariableNames: 'default'! ----- Method: PackageInfo class>>allPackages (in category 'packages access') ----- allPackages ^PackageOrganizer default packages! ----- Method: PackageInfo class>>default (in category 'compatibility') ----- default ^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register]! ----- Method: PackageInfo class>>initialize (in category 'class initialization') ----- initialize self allSubclassesDo: [:ea | ea new register]! ----- Method: PackageInfo class>>named: (in category 'packages access') ----- named: aString ^ PackageOrganizer default packageNamed: aString ifAbsent: [(self new packageName: aString) register]! ----- Method: PackageInfo class>>registerPackage: (in category 'registration / unregistration') ----- registerPackage: aString "for compatibility with old fileOuts" ^ Smalltalk at: #FilePackageManager ifPresent: [:p | p registerPackage: aString]! ----- Method: PackageInfo class>>registerPackageName: (in category 'registration / unregistration') ----- registerPackageName: aString ^ PackageOrganizer default registerPackageNamed: aString! ----- Method: PackageInfo>>= (in category 'comparing') ----- = other ^ other species = self species and: [other packageName = self packageName]! ----- Method: PackageInfo>>actualMethodsDo: (in category 'enumerating') ----- actualMethodsDo: aBlock "Evaluate aBlock with the actual method objects in this package." | enum | self extensionMethods do: [:mr| aBlock value: mr compiledMethod]. enum := [:behavior| behavior organization categories do: [:cat| (self isForeignClassExtension: cat) ifFalse: [(behavior organization listAtCategoryNamed: cat) do: [:s| aBlock value: (behavior compiledMethodAt: s)]]]]. self classes do: [:c| enum value: c; value: c classSide] ! ----- Method: PackageInfo>>addCoreMethod: (in category 'modifying') ----- addCoreMethod: aMethodReference | category | category := self baseCategoryOfMethod: aMethodReference. aMethodReference actualClass organization classify: aMethodReference methodSymbol under: category suppressIfDefault: false! ----- Method: PackageInfo>>addExtensionMethod: (in category 'modifying') ----- addExtensionMethod: aMethodReference | category | category := self baseCategoryOfMethod: aMethodReference. aMethodReference actualClass organization classify: aMethodReference methodSymbol under: self methodCategoryPrefix, '-', category! ----- Method: PackageInfo>>addMethod: (in category 'modifying') ----- addMethod: aMethodReference (self includesClass: aMethodReference class) ifTrue: [self addCoreMethod: aMethodReference] ifFalse: [self addExtensionMethod: aMethodReference]! ----- Method: PackageInfo>>allOverriddenMethods (in category 'listing') ----- allOverriddenMethods "search classes and meta classes" ^ Array streamContents: [:stream | self allOverriddenMethodsDo: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>allOverriddenMethodsDo: (in category 'enumerating') ----- allOverriddenMethodsDo: aBlock "Evaluates aBlock with all the overridden methods in the system" ^ ProtoObject withAllSubclassesDo: [:class | self overriddenMethodsInClass: class do: aBlock] ! ----- Method: PackageInfo>>baseCategoryOfMethod: (in category 'modifying') ----- 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: $- ]]! ----- Method: PackageInfo>>category:matches: (in category 'testing') ----- category: categoryName matches: prefix | prefixSize catSize | categoryName ifNil: [ ^false ]. catSize := categoryName size. prefixSize := prefix size. catSize < prefixSize ifTrue: [ ^false ]. (categoryName findString: prefix startingAt: 1 caseSensitive: false) = 1 ifFalse: [ ^false ]. ^(categoryName at: prefix size + 1 ifAbsent: [ ^true ]) = $-! ----- Method: PackageInfo>>categoryName (in category 'naming') ----- categoryName |category| category := self class category. ^ (category endsWith: '-Info') ifTrue: [category copyUpToLast: $-] ifFalse: [category]! ----- Method: PackageInfo>>changeRecordForOverriddenMethod: (in category 'testing') ----- changeRecordForOverriddenMethod: aMethodReference self changeRecordsForMethod: aMethodReference do: [:record | (self includesMethodCategory: record category ofClass: aMethodReference actualClass) ifTrue: [^record]]. ^nil! ----- Method: PackageInfo>>changeRecordsForMethod:do: (in category 'enumerating') ----- changeRecordsForMethod: aMethodReference do: aBlock "Evaluate aBlock with one ChangeRecord per overriding package, followed by the latest non-override" | overridingPackages method position sourceFilesCopy | overridingPackages := Set new. method := aMethodReference compiledMethod. position := method filePosition. sourceFilesCopy := SourceFiles collect: [:x | x ifNotNil: [x readOnlyCopy]]. [ | file prevPos prevFileIndex chunk stamp methodCategory methodPackage tokens | method fileIndex = 0 ifTrue: [^ nil]. file := sourceFilesCopy at: method fileIndex. [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: [chunk := file nextChunk]. "Preamble is likely a linked method preamble, if we're in a changes file (not the sources file). Try to parse it for prior source position and file index" prevPos := nil. stamp := ''. (chunk findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [tokens := Scanner new scanTokens: chunk] ifFalse: [tokens := Array new "ie cant be back ref"]. ((tokens size between: 7 and: 8) and: [(tokens at: tokens size-5) = #methodsFor:]) ifTrue: [(tokens at: tokens size-3) = #stamp: 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: ["Old format gives no stamp; prior pointer in two parts" prevPos := tokens at: tokens size-2. prevFileIndex := tokens last]. (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]]. ((tokens size between: 5 and: 6) and: [(tokens at: tokens size-3) = #methodsFor:]) ifTrue: [(tokens at: tokens size-1) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size]]. methodCategory := tokens after: #methodsFor: ifAbsent: [ClassOrganizer default]. methodPackage := PackageOrganizer default packageOfMethodCategory: methodCategory ofClass: aMethodReference actualClass ifNone: [#unknown]. (overridingPackages includes: methodPackage) ifFalse: [aBlock value: (ChangeRecord new file: file position: position type: #method class: aMethodReference classSymbol category: methodCategory meta: aMethodReference classIsMeta stamp: stamp)]. (self isOverrideCategory: methodCategory) ifTrue: [overridingPackages add: methodPackage] ifFalse: [(overridingPackages includes: methodPackage) ifFalse: [^nil]]. position := prevPos. prevPos notNil ifTrue: [file := sourceFilesCopy at: prevFileIndex]]. ^nil] ensure: [sourceFilesCopy do: [:x | x ifNotNil: [x close]]] ! ----- Method: PackageInfo>>classes (in category 'listing') ----- classes ^(self systemCategories gather: [:cat | (SystemOrganization listAtCategoryNamed: cat) collect: [:className | Smalltalk at: className]]) sortBy: [:a :b | a className <= b className]! ----- Method: PackageInfo>>classesAndMetaClasses (in category 'listing') ----- classesAndMetaClasses "Return a Set with all classes and metaclasses belonging to this package" | baseClasses result | baseClasses := self classes. result := (Set new: baseClasses size * 2) addAll: baseClasses; yourself. baseClasses do: [ :c | result add: c classSide]. ^result ! ----- Method: PackageInfo>>coreCategoriesForClass: (in category 'testing') ----- coreCategoriesForClass: aClass ^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]! ----- Method: PackageInfo>>coreMethods (in category 'listing') ----- coreMethods ^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]! ----- Method: PackageInfo>>coreMethodsForClass: (in category 'testing') ----- coreMethodsForClass: aClass ^ (aClass selectors difference: ((self foreignExtensionMethodsForClass: aClass) collect: [:r | r methodSymbol])) asArray collect: [:sel | self referenceForMethod: sel ofClass: aClass]! ----- Method: PackageInfo>>extensionCategoriesForClass: (in category 'testing') ----- extensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isYourClassExtension: cat]! ----- Method: PackageInfo>>extensionClasses (in category 'listing') ----- extensionClasses ^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty]! ----- Method: PackageInfo>>extensionMethods (in category 'listing') ----- extensionMethods ^ self externalBehaviors gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]! ----- Method: PackageInfo>>extensionMethodsForClass: (in category 'testing') ----- extensionMethodsForClass: aClass ^ (self extensionCategoriesForClass: aClass) gather: [:cat | self methodsInCategory: cat ofClass: aClass ]! ----- Method: PackageInfo>>extensionMethodsFromClasses: (in category 'testing') ----- extensionMethodsFromClasses: classes ^classes gather: [:class | self extensionMethodsForClass: class]! ----- Method: PackageInfo>>externalBehaviors (in category 'modifying') ----- externalBehaviors ^self externalClasses , self externalTraits! ----- Method: PackageInfo>>externalCallers (in category 'dependencies') ----- externalCallers ^ self externalRefsSelect: [:literal | literal isKindOf: Symbol] thenCollect: [:l | l].! ----- Method: PackageInfo>>externalClasses (in category 'dependencies') ----- externalClasses | myClasses | myClasses := self classesAndMetaClasses. ^ Array streamContents: [:s | ProtoObject withAllSubclassesDo: [:class | (myClasses includes: class) ifFalse: [s nextPut: class]]]! ----- Method: PackageInfo>>externalName (in category 'naming') ----- externalName ^ self packageName! ----- Method: PackageInfo>>externalRefsSelect:thenCollect: (in category 'dependencies') ----- externalRefsSelect: selBlock thenCollect: colBlock | pkgMethods dependents 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 | | refs | (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! ----- Method: PackageInfo>>externalSubclasses (in category 'dependencies') ----- externalSubclasses | pkgClasses subClasses | pkgClasses := self classes. subClasses := Set new. pkgClasses do: [:c | subClasses addAll: (c allSubclasses)]. ^ subClasses difference: pkgClasses ! ----- Method: PackageInfo>>externalTraits (in category 'modifying') ----- externalTraits ^ Array streamContents: [:s | | behaviors | behaviors := self classesAndMetaClasses. Smalltalk allTraits do: [:trait | (behaviors includes: trait) ifFalse: [s nextPut: trait]. (behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]]. ! ----- Method: PackageInfo>>externalUsers (in category 'dependencies') ----- externalUsers ^ self externalRefsSelect: [:literal | literal isVariableBinding] thenCollect: [:l | l key]! ----- Method: PackageInfo>>foreignClasses (in category 'listing') ----- 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! ----- Method: PackageInfo>>foreignExtensionCategoriesForClass: (in category 'testing') ----- foreignExtensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]! ----- Method: PackageInfo>>foreignExtensionMethodsForClass: (in category 'testing') ----- foreignExtensionMethodsForClass: aClass ^ (self foreignExtensionCategoriesForClass: aClass) gather: [:cat | (aClass organization listAtCategoryNamed: cat) collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! ----- Method: PackageInfo>>foreignSystemCategories (in category 'listing') ----- foreignSystemCategories ^ SystemOrganization categories reject: [:cat | self includesSystemCategory: cat] ! ----- Method: PackageInfo>>hasPostscript (in category 'preamble/postscript') ----- hasPostscript ^ self isScript: postscript not: self postscriptDefault! ----- Method: PackageInfo>>hasPostscriptOfRemoval (in category 'preamble/postscript') ----- hasPostscriptOfRemoval ^ self isScript: postscriptOfRemoval not: self postscriptOfRemovalDefault! ----- Method: PackageInfo>>hasPreamble (in category 'preamble/postscript') ----- hasPreamble ^ self isScript: preamble not: self preambleDefault! ----- Method: PackageInfo>>hasPreambleOfRemoval (in category 'preamble/postscript') ----- hasPreambleOfRemoval ^ self isScript: preambleOfRemoval not: self preambleOfRemovalDefault! ----- Method: PackageInfo>>hash (in category 'comparing') ----- hash ^ packageName hash! ----- Method: PackageInfo>>includesChangeRecord: (in category 'testing') ----- includesChangeRecord: aChangeRecord ^ aChangeRecord methodClass notNil and: [self includesMethodCategory: aChangeRecord category ofClass: aChangeRecord methodClass]! ----- Method: PackageInfo>>includesClass: (in category 'testing') ----- includesClass: aClass ^ self includesSystemCategory: aClass category! ----- Method: PackageInfo>>includesClassNamed: (in category 'testing') ----- includesClassNamed: aClassName ^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false])! ----- Method: PackageInfo>>includesMethod:ofClass: (in category 'testing') ----- includesMethod: aSymbol ofClass: aClass aClass ifNil: [^ false]. ^ self includesMethodCategory: ((aClass organization categoryOfElement: aSymbol) ifNil: [' ']) ofClass: aClass! ----- Method: PackageInfo>>includesMethodCategory:ofClass: (in category 'testing') ----- includesMethodCategory: categoryName ofClass: aClass ^ (self isYourClassExtension: categoryName) or: [(self includesClass: aClass) and: [(self isForeignClassExtension: categoryName) not]]! ----- Method: PackageInfo>>includesMethodCategory:ofClassNamed: (in category 'testing') ----- includesMethodCategory: categoryName ofClassNamed: aClass ^ (self isYourClassExtension: categoryName) or: [(self includesClassNamed: aClass) and: [(self isForeignClassExtension: categoryName) not]]! ----- Method: PackageInfo>>includesMethodReference: (in category 'testing') ----- includesMethodReference: aMethodRef ^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass! ----- Method: PackageInfo>>includesSystemCategory: (in category 'testing') ----- includesSystemCategory: categoryName ^ self category: categoryName matches: self systemCategoryPrefix! ----- Method: PackageInfo>>isForeignClassExtension: (in category 'testing') ----- isForeignClassExtension: categoryName ^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! ----- Method: PackageInfo>>isOverrideCategory: (in category 'testing') ----- isOverrideCategory: aString ^ aString first = $* and: [aString endsWith: '-override']! ----- Method: PackageInfo>>isOverrideMethod: (in category 'testing') ----- isOverrideMethod: aMethodReference ^ self isOverrideCategory: aMethodReference category! ----- Method: PackageInfo>>isOverrideOfYourMethod: (in category 'testing') ----- isOverrideOfYourMethod: aMethodReference "Answers true if the argument overrides a method in this package" ^ (self isYourClassExtension: aMethodReference category) not and: [(self changeRecordForOverriddenMethod: aMethodReference) notNil]! ----- Method: PackageInfo>>isScript:not: (in category 'preamble/postscript') ----- isScript: script not: default ^ script notNil and: [ | contents | contents := script contents asString withBlanksTrimmed. contents notEmpty and: [contents ~= default and: [contents ~= 'nil']]]! ----- Method: PackageInfo>>isYourClassExtension: (in category 'testing') ----- isYourClassExtension: categoryName ^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! ----- Method: PackageInfo>>linesOfCode (in category 'source code management') ----- linesOfCode "An approximate measure of lines of code. Includes comments, but excludes blank lines." ^self methods inject: 0 into: [:sum :each | sum + each compiledMethod linesOfCode]! ----- Method: PackageInfo>>methodCategoryPrefix (in category 'naming') ----- methodCategoryPrefix ^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase]! ----- Method: PackageInfo>>methods (in category 'listing') ----- methods ^ (self extensionMethods, self coreMethods) select: [:method | method isValid and: [method isLocalSelector]]! ----- Method: PackageInfo>>methodsInCategory:ofClass: (in category 'testing') ----- methodsInCategory: aString ofClass: aClass ^Array streamContents: [:stream | self methodsInCategory: aString ofClass: aClass do: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>methodsInCategory:ofClass:do: (in category 'enumerating') ----- methodsInCategory: aString ofClass: aClass do: aBlock ((aClass organization listAtCategoryNamed: aString) ifNil: [^self]) do: [:sel | aBlock value: (self referenceForMethod: sel ofClass: aClass)]! ----- Method: PackageInfo>>name (in category 'naming') ----- name ^ self packageName! ----- Method: PackageInfo>>outsideClasses (in category 'testing') ----- outsideClasses ^ProtoObject withAllSubclasses asSet difference: self classesAndMetaClasses! ----- Method: PackageInfo>>overriddenMethods (in category 'listing') ----- overriddenMethods ^ Array streamContents: [:stream | self overriddenMethodsDo: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>overriddenMethodsDo: (in category 'enumerating') ----- overriddenMethodsDo: aBlock "Enumerates the methods the receiver contains which have been overridden by other packages" ^ self allOverriddenMethodsDo: [:ea | (self isOverrideOfYourMethod: ea) ifTrue: [aBlock value: ea]]! ----- Method: PackageInfo>>overriddenMethodsInClass: (in category 'listing') ----- overriddenMethodsInClass: aClass ^Array streamContents: [:stream | self overriddenMethodsInClass: aClass do: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>overriddenMethodsInClass:do: (in category 'enumerating') ----- overriddenMethodsInClass: aClass do: aBlock "Evaluates aBlock with the overridden methods in aClass" ^ self overrideCategoriesForClass: aClass do: [:cat | self methodsInCategory: cat ofClass: aClass do: aBlock]! ----- Method: PackageInfo>>overrideCategoriesForClass: (in category 'testing') ----- overrideCategoriesForClass: aClass ^Array streamContents: [:stream | self overrideCategoriesForClass: aClass do: [:each | stream nextPut: each]] ! ----- Method: PackageInfo>>overrideCategoriesForClass:do: (in category 'enumerating') ----- overrideCategoriesForClass: aClass do: aBlock "Evaluates aBlock with all the *foo-override categories in aClass" ^ aClass organization categories do: [:cat | (self isOverrideCategory: cat) ifTrue: [aBlock value: cat]]! ----- Method: PackageInfo>>overrideMethods (in category 'listing') ----- overrideMethods ^ self extensionMethods select: [:ea | self isOverrideMethod: ea]! ----- Method: PackageInfo>>packageName (in category 'naming') ----- packageName ^ packageName ifNil: [packageName := self categoryName]! ----- Method: PackageInfo>>packageName: (in category 'naming') ----- packageName: aString packageName := aString! ----- Method: PackageInfo>>postscript (in category 'preamble/postscript') ----- postscript ^ postscript ifNil: [ postscript := StringHolder new contents: self postscriptDefault]! ----- Method: PackageInfo>>postscript: (in category 'preamble/postscript') ----- postscript: aString postscript := StringHolder new contents: aString! ----- Method: PackageInfo>>postscriptDefault (in category 'preamble/postscript') ----- postscriptDefault ^ '"below, add code to be run after the loading of this package"'! ----- Method: PackageInfo>>postscriptOfRemoval (in category 'preamble/postscript') ----- postscriptOfRemoval ^ postscriptOfRemoval ifNil: [ postscriptOfRemoval := StringHolder new contents: self postscriptOfRemovalDefault]! ----- Method: PackageInfo>>postscriptOfRemoval: (in category 'preamble/postscript') ----- postscriptOfRemoval: aString postscriptOfRemoval := StringHolder new contents: aString ! ----- Method: PackageInfo>>postscriptOfRemovalDefault (in category 'preamble/postscript') ----- postscriptOfRemovalDefault ^ '"below, add code to clean up after the unloading of this package"'! ----- Method: PackageInfo>>preamble (in category 'preamble/postscript') ----- preamble ^ preamble ifNil: [ preamble := StringHolder new contents: self preambleDefault]! ----- Method: PackageInfo>>preamble: (in category 'preamble/postscript') ----- preamble: aString preamble := StringHolder new contents: aString! ----- Method: PackageInfo>>preambleDefault (in category 'preamble/postscript') ----- preambleDefault ^ '"below, add code to be run before the loading of this package"' ! ----- Method: PackageInfo>>preambleOfRemoval (in category 'preamble/postscript') ----- preambleOfRemoval ^ preambleOfRemoval ifNil: [ preambleOfRemoval := StringHolder new contents: self preambleOfRemovalDefault]! ----- Method: PackageInfo>>preambleOfRemoval: (in category 'preamble/postscript') ----- preambleOfRemoval: aString preambleOfRemoval := StringHolder new contents: aString ! ----- Method: PackageInfo>>preambleOfRemovalDefault (in category 'preamble/postscript') ----- preambleOfRemovalDefault ^'"below, add code to prepare for the unloading of this package"'! ----- Method: PackageInfo>>printOn: (in category 'printing') ----- printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self packageName; nextPut: $)! ----- Method: PackageInfo>>referenceForMethod:ofClass: (in category 'testing') ----- referenceForMethod: aSymbol ofClass: aClass ^ MethodReference class: aClass selector: aSymbol! ----- Method: PackageInfo>>register (in category 'registering') ----- register PackageOrganizer default registerPackage: self! ----- Method: PackageInfo>>removeMethod: (in category 'modifying') ----- removeMethod: aMethodReference! ----- Method: PackageInfo>>selectors (in category 'listing') ----- selectors ^ self methods collect: [:ea | ea methodSymbol]! ----- Method: PackageInfo>>systemCategories (in category 'listing') ----- systemCategories ^ SystemOrganization categories select: [:cat | self includesSystemCategory: cat]! ----- Method: PackageInfo>>systemCategoryPrefix (in category 'naming') ----- systemCategoryPrefix ^ self packageName! Object subclass: #PackageOrganizer instanceVariableNames: 'packages' classVariableNames: '' poolDictionaries: '' category: 'PackageInfo-Base'! PackageOrganizer class instanceVariableNames: 'default'! PackageOrganizer class instanceVariableNames: 'default'! ----- Method: PackageOrganizer class>>default (in category 'as yet unclassified') ----- default ^ default ifNil: [default := self new]! ----- Method: PackageOrganizer class>>new (in category 'as yet unclassified') ----- new ^ self basicNew initialize! ----- Method: PackageOrganizer>>flushObsoletePackages: (in category 'registering') ----- flushObsoletePackages: aBlock "Flush all packages considered obsolete by evaluating the argument block." packages keys do:[:key| (aBlock value: (packages at: key)) ifTrue:[packages removeKey: key]. ]. self changed: #packages; changed: #packageNames.! ----- Method: PackageOrganizer>>initialize (in category 'initializing') ----- initialize packages := Dictionary new! ----- Method: PackageOrganizer>>noPackageFound (in category 'searching') ----- noPackageFound self error: 'No package found'! ----- Method: PackageOrganizer>>packageNamed:ifAbsent: (in category 'searching') ----- packageNamed: aString ifAbsent: errorBlock ^ packages at: aString ifAbsent: errorBlock! ----- Method: PackageOrganizer>>packageNames (in category 'accessing') ----- packageNames ^ packages keys! ----- Method: PackageOrganizer>>packageOfClass: (in category 'searching') ----- packageOfClass: aClass ^ self packageOfClass: aClass ifNone: [self noPackageFound]! ----- Method: PackageOrganizer>>packageOfClass:ifNone: (in category 'searching') ----- packageOfClass: aClass ifNone: errorBlock ^ self packages detect: [:ea | ea includesClass: aClass] ifNone: errorBlock! ----- Method: PackageOrganizer>>packageOfMethod: (in category 'searching') ----- packageOfMethod: aMethodReference ^ self packageOfMethod: aMethodReference ifNone: [self noPackageFound]! ----- Method: PackageOrganizer>>packageOfMethod:ifNone: (in category 'searching') ----- packageOfMethod: aMethodReference ifNone: errorBlock ^ self packages detect: [:ea | ea includesMethodReference: aMethodReference] ifNone: errorBlock! ----- Method: PackageOrganizer>>packageOfMethodCategory:ofClass: (in category 'searching') ----- packageOfMethodCategory: categoryName ofClass: aClass ^self packageOfMethodCategory: categoryName ofClass: aClass ifNone: [ self noPackageFound ] ! ----- Method: PackageOrganizer>>packageOfMethodCategory:ofClass:ifNone: (in category 'searching') ----- packageOfMethodCategory: categoryName ofClass: aClass ifNone: errorBlock ^ self packages detect: [:ea | ea includesMethodCategory: categoryName ofClassNamed: aClass name] ifNone: errorBlock ! ----- Method: PackageOrganizer>>packageOfSystemCategory: (in category 'searching') ----- packageOfSystemCategory: aSystemCategory ^ self packageOfSystemCategory: aSystemCategory ifNone: [ self noPackageFound ] ! ----- Method: PackageOrganizer>>packageOfSystemCategory:ifNone: (in category 'searching') ----- packageOfSystemCategory: aSystemCategory ifNone: errorBlock ^ self packages detect: [:ea | ea includesSystemCategory: aSystemCategory] ifNone: errorBlock ! ----- Method: PackageOrganizer>>packages (in category 'accessing') ----- packages ^ packages values! ----- Method: PackageOrganizer>>registerPackage: (in category 'registering') ----- registerPackage: aPackageInfo packages at: aPackageInfo packageName put: aPackageInfo. self changed: #packages; changed: #packageNames. ! ----- Method: PackageOrganizer>>registerPackageNamed: (in category 'registering') ----- registerPackageNamed: aString ^ self registerPackage: (PackageInfo named: aString)! ----- Method: PackageOrganizer>>unregisterPackage: (in category 'registering') ----- unregisterPackage: aPackageInfo packages removeKey: aPackageInfo packageName ifAbsent: []. self changed: #packages; changed: #packageNames. ! ----- Method: PackageOrganizer>>unregisterPackageNamed: (in category 'registering') ----- unregisterPackageNamed: aString self unregisterPackage: (self packageNamed: aString ifAbsent: [^ self])! Object subclass: #PackageServices instanceVariableNames: '' classVariableNames: 'ServiceClasses' poolDictionaries: '' category: 'PackageInfo-Base'! ----- Method: PackageServices class>>allServices (in category 'as yet unclassified') ----- allServices ^ ServiceClasses gather: [:ea | ea services]! ----- Method: PackageServices class>>initialize (in category 'as yet unclassified') ----- initialize ServiceClasses := Set new! ----- Method: PackageServices class>>register: (in category 'as yet unclassified') ----- register: aClass ServiceClasses add: aClass! ----- Method: PackageServices class>>unregister: (in category 'as yet unclassified') ----- unregister: aClass ServiceClasses remove: aClass! ----- Method: PositionableStream>>untilEnd:displayingProgress: (in category '*packageinfo-base') ----- untilEnd: aBlock displayingProgress: aString aString displayProgressFrom: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. aBlock value]].! From commits at source.squeak.org Fri Jun 5 20:19:19 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:19:20 2015 Subject: [squeak-dev] Squeak 4.6: ST80Tools-cmm.8.mcz Message-ID: Chris Muller uploaded a new version of ST80Tools to project Squeak 4.6: http://source.squeak.org/squeak46/ST80Tools-cmm.8.mcz ==================== Summary ==================== Name: ST80Tools-cmm.8 Author: cmm Time: 21 April 2015, 4:49:40.23 pm UUID: 1d69716a-4a2c-44e6-9bae-2613b5590947 Ancestors: ST80Tools-mt.7 Fix underscore assignment. ==================== Snapshot ==================== ----- Method: ParagraphEditor>>browseChangeSetsWithSelector (in category '*ST80Tools') ----- 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]! ----- Method: ParagraphEditor>>browseItHere (in category '*ST80Tools') ----- browseItHere "Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw" | aSymbol b | (((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass]) ifFalse: [^ view flash]. model okToChange ifFalse: [^ view flash]. self selectionInterval isEmpty ifTrue: [self selectWord]. (aSymbol := self selectedSymbol) ifNil: [^ view flash]. self terminateAndInitializeAround: [| foundClass | foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]). foundClass ifNil: [^ view flash]. (foundClass isKindOf: Class) ifTrue: [model selectSystemCategory: foundClass category. model classListIndex: (model classList indexOf: foundClass name)]]! ----- Method: ParagraphEditor>>debug:receiver:in: (in category '*ST80Tools') ----- debug: aCompiledMethod receiver: anObject in: evalContext | guineaPig debugger debuggerWindow context | guineaPig := [aCompiledMethod valueWithReceiver: anObject arguments: (evalContext ifNil: [ #() ] ifNotNil: [ { evalContext } ]). guineaPig := nil "spot the return from aCompiledMethod"] newProcess. context := guineaPig suspendedContext. debugger := Debugger new process: guineaPig controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) ifTrue: [ScheduledControllers activeController]) context: context. debuggerWindow := debugger openFullNoSuspendLabel: 'Debug it'. "Now step into the expression. But if it is quick (is implemented as a primtiive, e.g. `0') it will return immediately back to the block that is sent newProcess above. Guard against that with the check for home being thisContext." [debugger interruptedContext method == aCompiledMethod] whileFalse: [(guineaPig isNil and: [debugger interruptedContext home == thisContext]) ifTrue: [debuggerWindow controller closeAndUnschedule. UIManager default inform: 'Nothing to debug; expression is optimized'. ^self]. debugger send]! ----- Method: ParagraphEditor>>debugIt (in category '*ST80Tools') ----- debugIt | method receiver context | (model respondsTo: #doItReceiver) ifTrue: [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].! ----- Method: StringHolderView>>canHaveUnacceptedEdits (in category '*ST80Tools-multi-window support') ----- canHaveUnacceptedEdits "Answer if the receiver is an object that can hold unaccepted edits (such as a text editor widget)" ^true! ----- Method: StringHolderView>>unacceptedEditState (in category '*ST80Tools-multi-window support') ----- unacceptedEditState ^hasUnacceptedEdits ifTrue: [displayContents text]! ----- Method: StringHolderView>>unacceptedEditState: (in category '*ST80Tools-multi-window support') ----- unacceptedEditState: stateOrNil (hasUnacceptedEdits := stateOrNil notNil) ifTrue: [self editString: stateOrNil]! ----- Method: ScreenController>>browseRecentLog (in category '*ST80Tools') ----- browseRecentLog "Open a changelist browser on changes submitted since the last snapshot. 1/17/96 sw" ChangeList browseRecentLog! ----- Method: ScreenController>>chooseDirtyBrowser (in category '*ST80Tools') ----- chooseDirtyBrowser "Put up a list of browsers with unsubmitted edits and activate the one selected by the user, if any." "ScheduledControllers screenController chooseDirtyBrowser" ScheduledControllers findWindowSatisfying: [:c | (c model isKindOf: Browser) and: [c model canDiscardEdits not]]. ! ----- Method: ScreenController>>openChangeManager (in category '*ST80Tools') ----- openChangeManager "Open a dual change sorter. For looking at two change sets at once." DualChangeSorter new open! ----- Method: ScreenController>>openFile (in category '*ST80Tools') ----- openFile FileList openFileDirectly! ----- Method: ScreenController>>openFileList (in category '*ST80Tools') ----- openFileList "Create and schedule a FileList view for specifying files to access." FileList openInMVC! ----- Method: ScreenController>>openPackageBrowser (in category '*ST80Tools') ----- openPackageBrowser "Create and schedule a Browser view for browsing code." PackagePaneBrowser openBrowser! ----- Method: ScreenController>>openSelectorBrowser (in category '*ST80Tools') ----- openSelectorBrowser "Create and schedule a selector fragment window." SelectorBrowser new open! ----- Method: ScreenController>>openSimpleChangeSorter (in category '*ST80Tools') ----- openSimpleChangeSorter ChangeSorter new open! ----- Method: FileList class>>openInMVC (in category '*ST80Tools-instance creation') ----- openInMVC "Open a view of an instance of me on the default directory." | dir aFileList topView volListView templateView fileListView fileContentsView underPane pHeight | dir := FileDirectory default. aFileList := self new directory: dir. topView := StandardSystemView new. topView model: aFileList; label: dir pathName; minimumSize: 200@200. topView borderWidth: 1. volListView := PluggableListView on: aFileList list: #volumeList selected: #volumeListIndex changeSelected: #volumeListIndex: menu: #volumeMenu:. volListView autoDeselect: false. volListView window: (0@0 extent: 80@45). topView addSubView: volListView. templateView := PluggableTextView on: aFileList text: #pattern accept: #pattern:. templateView askBeforeDiscardingEdits: false. templateView window: (0@0 extent: 80@15). topView addSubView: templateView below: volListView. aFileList wantsOptionalButtons ifTrue: [underPane := aFileList optionalButtonViewForMVC. underPane isNil ifTrue: [pHeight := 60] ifFalse: [ topView addSubView: underPane toRightOf: volListView. pHeight := 60 - aFileList optionalButtonHeight]] ifFalse: [underPane := nil. pHeight := 60]. fileListView := PluggableListView on: aFileList list: #fileList selected: #fileListIndex changeSelected: #fileListIndex: menu: #fileListMenu:. fileListView window: (0@0 extent: 120@pHeight). underPane isNil ifTrue: [topView addSubView: fileListView toRightOf: volListView] ifFalse: [topView addSubView: fileListView below: underPane]. fileListView controller terminateDuringSelect: true. "Pane to left may change under scrollbar" fileContentsView := PluggableTextView on: aFileList text: #contents accept: #put: readSelection: #contentsSelection menu: #fileContentsMenu:shifted:. fileContentsView window: (0@0 extent: 200@140). topView addSubView: fileContentsView below: templateView. topView controller open! ----- Method: FileList>>optionalButtonViewForMVC (in category '*ST80Tools-initialization') ----- optionalButtonViewForMVC "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! From commits at source.squeak.org Fri Jun 5 20:19:29 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:19:35 2015 Subject: [squeak-dev] Squeak 4.6: SqueakSSL-Core-ul.29.mcz Message-ID: Chris Muller uploaded a new version of SqueakSSL-Core to project Squeak 4.6: http://source.squeak.org/squeak46/SqueakSSL-Core-ul.29.mcz ==================== Summary ==================== Name: SqueakSSL-Core-ul.29 Author: ul Time: 16 October 2014, 10:36:36.902 am UUID: e50d2a4f-cf16-4cdf-9ced-0d7471e550c6 Ancestors: SqueakSSL-Core-ul.28 Made #serverName: backwards compatible, by ignoring the primitive failure, when the plugin doesn't support it. ==================== Snapshot ==================== SystemOrganization addCategory: #'SqueakSSL-Core'! SocketStream subclass: #SecureSocketStream instanceVariableNames: 'ssl sendBuf readBuf decoded certIssues' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-Core'! !SecureSocketStream commentStamp: 'ar 7/25/2010 14:19' prior: 0! A variant on SocketStream supporting SSL/TLS encryption via SqueakSSL. ! ----- Method: SecureSocketStream>>ascii (in category 'accessing') ----- ascii "Switch to ASCII" super ascii. decoded := (ReadStream on: decoded originalContents asString from: 1 to: decoded size) position: decoded position; yourself. ! ----- Method: SecureSocketStream>>atEnd (in category 'private-compat') ----- atEnd "Pre Squeak 4.2 compatibility" self receiveAvailableData. ^super atEnd! ----- Method: SecureSocketStream>>binary (in category 'accessing') ----- binary "Switch to binary" super binary. decoded := (ReadStream on: decoded originalContents asByteArray from: 1 to: decoded size) position: decoded position; yourself. ! ----- Method: SecureSocketStream>>certError:code: (in category 'errors') ----- certError: errorString code: reason "Signal an issue with a certificate. If the reason code matches the acceptable cert issues, continue, otherwise signal an error." (certIssues allMask: reason) ifTrue:[^self]. ^SqueakSSLCertificateError signal: errorString, '(code: ', reason, ')'. ! ----- Method: SecureSocketStream>>certState (in category 'accessing') ----- certState "Returns the certificate verification bits. The returned value indicates whether the certificate is valid. The two standard values are: 0 - The certificate is valid. -1 - No certificate has been provided by the peer. Otherwise, the result is a bit mask of the following values: 1 - If set, there is an unspecified issue with the cert (generic error) 2 - If set, the root CA is untrusted (usually a self-signed cert) 4 - If set, the certificate is expired. 8 - If set, the certificate is used for the wrong purpose 16 - If set, the CN of the certificate is invalid. 32 - If set, the certificate was revoked. " ^ssl ifNotNil:[ssl certState]! ----- Method: SecureSocketStream>>close (in category 'initialize') ----- close "Flush any data still not sent and take care of the socket." super close. ssl ifNotNil:[ ssl destroy. ssl := nil. ].! ----- Method: SecureSocketStream>>destroy (in category 'initialize') ----- destroy "Destroy the receiver and its underlying socket. Does not attempt to flush the output buffers. For a graceful close use SocketStream>>close instead." "Pre-4.2 compatibility. Should be 'super destroy' instead of 'socket destroy'" socket ifNotNil:[ socket destroy. socket := nil. ]. ssl ifNotNil:[ ssl destroy. ssl := nil. ].! ----- Method: SecureSocketStream>>flush (in category 'private-compat') ----- flush "Pre-Squeak 4.2 compatibility" ((outNextToWrite > 1) and: [socket isOtherEndClosed not]) ifTrue: [ [self sendData: outBuffer count: outNextToWrite - 1] on: ConnectionTimedOut do: [:ex | shouldSignal ifFalse: ["swallow"]]. outNextToWrite := 1] ! ----- Method: SecureSocketStream>>ignoredCertIssues (in category 'accessing') ----- ignoredCertIssues "Answer the mask of 'acceptable issues' with certs. To completely ignore all cert issues use -1 which still ensures privacy (encryption) to the remote host, but does not guard against a man-in-the-middle attack (i.e., you cannot be sure that the remote host is what he says he is). The reasons are a bit mask consisting of the following values: 1 - If set, there is an unspecified issue with the cert (generic error) 2 - If set, the root CA is untrusted (usually a self-signed cert) 4 - If set, the certificate is expired. 8 - If set, the certificate is used for the wrong purpose 16 - If set, the CN of the certificate is invalid. 32 - If set, the certificate was revoked. " ^certIssues! ----- Method: SecureSocketStream>>ignoredCertIssues: (in category 'accessing') ----- ignoredCertIssues: reasonsMask "Set the mask of 'acceptable issues' with certs. To completely ignore all cert issues use -1 which still ensures privacy (encryption) to the remote host, but does not guard against a man-in-the-middle attack (i.e., you cannot be sure that the remote host is what he says he is). The reasons are a bit mask consisting of the following values: 1 - If set, there is an unspecified issue with the cert (generic error) 2 - If set, the root CA is untrusted (usually a self-signed cert) 4 - If set, the certificate is expired. 8 - If set, the certificate is used for the wrong purpose 16 - If set, the CN of the certificate is invalid. 32 - If set, the certificate was revoked. " certIssues := reasonsMask! ----- Method: SecureSocketStream>>initialize (in category 'initialize') ----- initialize "Initialize the receiver" "I think 16k is the max for SSL frames so use a tad more" decoded := ReadStream on: (ByteArray new: 20000) from: 1 to: 0. super initialize. sendBuf := ByteArray new: 4096. readBuf := ByteArray new: 4096. certIssues := 0. ! ----- Method: SecureSocketStream>>isDataAvailable (in category 'private-compat') ----- isDataAvailable "Pre Squeak 4.2 compatibility" self isInBufferEmpty ifFalse: [^true]. ^self receiveAvailableData < inNextToWrite ! ----- Method: SecureSocketStream>>nextPutAllFlush: (in category 'private-compat') ----- nextPutAllFlush: aCollection "Pre Squeak 4.2 compatibility" | toPut | toPut := binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString]. self flush. "first flush pending stuff, then directly send" socket isOtherEndClosed ifFalse: [ [self sendData: toPut count: toPut size] on: ConnectionTimedOut do: [:ex | shouldSignal ifFalse: ["swallow"]]] ! ----- Method: SecureSocketStream>>peerName (in category 'accessing') ----- peerName "Returns the certificate name of the remote peer. The method only returns a name if the certificate has been verified." ^ssl ifNotNil:[ssl peerName]! ----- Method: SecureSocketStream>>receiveAvailableData (in category 'private-compat') ----- receiveAvailableData "Pre Squeak 4.2 compatibility" recentlyRead := self receiveDataInto: inBuffer startingAt: inNextToWrite. ^self adjustInBuffer: recentlyRead ! ----- Method: SecureSocketStream>>receiveData (in category 'private-socket') ----- receiveData "This method drains the available decryption data before waiting for the socket" | pos | "Note: The loop here is necessary to catch cases where a TLS packet is split among TCP packets. In this case we would pull the first portion of the TLS packet here but receiveAvailableData would return nothing since the contents of the packet can't be decoded until the rest has come in." [pos := inNextToWrite. self receiveAvailableData. pos = inNextToWrite ifFalse:[^pos]. "Pre-4.2 compatibility; should be 'super receiveData' instead." socket waitForDataFor: self timeout ifClosed: [self shouldSignal ifTrue:[ConnectionClosed signal: 'Connection closed while waiting for data.']] ifTimedOut: [self shouldTimeout ifTrue:[ConnectionTimedOut signal: 'Data receive timed out.']]. self isConnected] whileTrue. "Final attempt to read data if a non-signaling connection closes" ^self receiveAvailableData. ! ----- Method: SecureSocketStream>>receiveData: (in category 'private-compat') ----- receiveData: nBytes "Pre Squeak 4.2 compatibility" self receiveAvailableData. ^super receiveData: nBytes.! ----- Method: SecureSocketStream>>receiveDataIfAvailable (in category 'private-compat') ----- receiveDataIfAvailable "Pre Squeak 4.2 compatibility" ^self receiveAvailableData ! ----- Method: SecureSocketStream>>receiveDataInto:startingAt: (in category 'private-socket') ----- receiveDataInto: buffer startingAt: index "Read and decrypt the data from the underlying socket. " | count bytesRead | "While in handshake, use the superclass version" ssl ifNil:[ "Pre-4.2 compatibility; should be 'super receiveDataInto: buffer startingAt: index'" ^socket receiveAvailableDataInto: buffer startingAt: index. ]. "Only decode more data if all the decoded contents has been drained" decoded atEnd ifTrue:[ "Decrypt more data if available" bytesRead := 0. [count := ssl decrypt: readBuf from: 1 to: bytesRead into: decoded originalContents. count < 0 ifTrue:[^self error: 'SSL error, code: ', count]. bytesRead := 0. count = 0 ifTrue:[ bytesRead := socket receiveAvailableDataInto: readBuf startingAt: 1. ]. bytesRead = 0] whileFalse. "Update for number of bytes decoded" decoded setFrom: 1 to: count. ]. "Push data from decoded into the result buffer" count := (decoded size - decoded position) min: (buffer size - index + 1). (decoded next: count into: buffer startingAt: index) size < count ifTrue:[^self error: 'Unexpected read failure']. ^count ! ----- Method: SecureSocketStream>>sendData:count: (in category 'private-socket') ----- sendData: buffer count: n "Encrypts the data before sending it on the underlying socket. Breaks large chunks into 2k components to fit safely into ssl frame." | remain start amount count | "While in handshake, use the superclass version" ssl ifNil:[ "Pre-4.2 compatibility; should be 'super sendData: buffer count: n' instead" ^socket sendData: buffer count: n ]. "Break the input into reasonable chunks and send them" remain := n. start := 1. [remain > 0] whileTrue:[ amount := remain min: 2048. count := ssl encrypt: buffer from: start to: start+amount-1 into: sendBuf. socket sendData: sendBuf count: count. remain := remain - amount. start := start + amount. ].! ----- Method: SecureSocketStream>>ssl (in category 'accessing') ----- ssl "The SqueakSSL instance" ^ssl! ----- Method: SecureSocketStream>>sslAccept: (in category 'initialize') ----- sslAccept: certName "Perform the SSL server handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete." | squeakSSL result inbuf | inbuf := ''. squeakSSL := SqueakSSL new. squeakSSL certName: certName. "Perform the server handshake" [[squeakSSL isConnected] whileFalse:[ "Read input" self receiveData. inbuf := self nextAvailable. result := squeakSSL accept: inbuf from: 1 to: inbuf size into: sendBuf. "Check for errors first" result < -1 ifTrue:[^self error: 'SSL accept failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[ self nextPutAll: (sendBuf copyFrom: 1 to: result). self flush. ]. ]. "There should be no pending data at this point, ensure it is so. XXXX: If you ever see this problem, please inform me." self isInBufferEmpty ifFalse:[self error: 'Unexpected input data']. "We are connected. From here on, encryption will take place." ssl := squeakSSL. ] ifCurtailed:[ "Make sure we destroy the platform handle if the handshake gets interrupted" squeakSSL destroy. ]. ! ----- Method: SecureSocketStream>>sslConnect (in category 'initialize') ----- sslConnect "Perform the SSL client handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete." self sslConnectTo: nil! ----- Method: SecureSocketStream>>sslConnectTo: (in category 'initialize') ----- sslConnectTo: serverName "Perform the SSL client handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete. If serverName is not nil, then try to use it for SNI." | inbuf squeakSSL result | inbuf := ''. squeakSSL := SqueakSSL new. serverName ifNotNil: [ squeakSSL serverName: serverName ]. "Perform the SSL handshake" [[result := squeakSSL connect: inbuf from: 1 to: inbuf size into: sendBuf. result = 0] whileFalse:[ "Check for errors first" result < -1 ifTrue:[^self error: 'SSL connect failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[ self nextPutAll: (sendBuf copyFrom: 1 to: result). self flush. ]. "Read more input and repeat" self receiveData. inbuf := self nextAvailable. ]. "There should be no pending data at this point, ensure it is so. XXXX: If you ever see this problem, please inform me." self isInBufferEmpty ifFalse:[self error: 'Unexpected input data']. "We are connected. From here on, encryption will take place." ssl := squeakSSL. ] ifCurtailed:[ "Make sure we destroy the platform handle if the handshake gets interrupted" squeakSSL destroy. ]. ! ----- Method: SecureSocketStream>>upToAll: (in category 'private-compat') ----- upToAll: aStringOrByteArray "Pre Squeak 4.2 compatibility" ^self upToAll: aStringOrByteArray limit: 100000! ----- Method: SecureSocketStream>>upToAll:limit: (in category 'private-compat') ----- upToAll: aStringOrByteArray limit: nBytes "Pre Squeak 4.2 compatibility" | index sz result searchedSoFar target | "Deal with ascii vs. binary" self isBinary ifTrue:[target := aStringOrByteArray asByteArray] ifFalse:[target := aStringOrByteArray asString]. sz := target size. "Look in the current inBuffer first" index := inBuffer indexOfSubCollection: target startingAt: lastRead - sz + 2. (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" result := self nextInBuffer: index - lastRead - 1. self skip: sz. ^ result ]. [searchedSoFar := self inBufferSize. "Receive more data" self receiveData. recentlyRead > 0] whileTrue:[ "Data begins at lastRead + 1, we add searchedSoFar as offset and backs up sz - 1 so that we can catch any borderline hits." index := inBuffer indexOfSubCollection: target startingAt: (lastRead + searchedSoFar - sz + 2 max: 1). (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" result := self nextInBuffer: index - lastRead - 1. self skip: sz. ^ result ]. "Check if we've exceeded the max. amount" (nBytes notNil and:[inNextToWrite - lastRead > nBytes]) ifTrue:[^self nextAllInBuffer]. ]. "not found and (non-signaling) connection was closed" ^self nextAllInBuffer! ----- Method: SecureSocketStream>>verifyCert: (in category 'initialize') ----- verifyCert: hostName "Verifies the cert state and host name" | certFlags | certFlags := self certState. certFlags = -1 ifTrue:[^self certError: 'No certificate was provided' code: -1]. certFlags = 0 ifFalse:[self certError: 'Invalid certificate' code: certFlags]. (ssl peerName match: hostName) ifFalse:[self certError: 'Host name mismatch' code: -1].! Socket subclass: #SecureSocket instanceVariableNames: 'ssl decoded readBuf sendBuf' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-Core'! ----- Method: SecureSocket class>>google: (in category 'examples') ----- google: query "An example HTTPS query to encrypted.google.com. Example: SecureSocket google: 'squeak'. SecureSocket google: 'SqueakSSL'. " | hostName address socket | "Change the host name to try an https request to some other host" hostName := 'encrypted.google.com'.. address := NetNameResolver addressForName: hostName. socket := SecureSocket newTCP. "Connect the TCP socket" socket connectTo: address port: 443. socket waitForConnectionFor: 10. ["Handle the client handshake" socket sslConnectTo: hostName. "Verify that the cert is valid" socket certState = 0 ifFalse:[ self error: 'The certificate is invalid (code: ', socket certState,')'. ]. "If the certificate is valid, make sure we're were we wanted to go" (socket peerName match: hostName) ifFalse:[ self error: 'Host name mismatch: ', socket peerName. ]. "Send encrypted data" socket sendData: 'GET /search?q=', query,' HTTP/1.0', String crlf, 'Host: ', hostName, String crlf, 'Connection: close', String crlf, String crlf. "Wait for the response" ^String streamContents:[:s| [[true] whileTrue:[s nextPutAll: socket receiveData]] on: ConnectionClosed, ConnectionTimedOut do:[:ex| ex return]. ]] ensure:[socket destroy]. ! ----- Method: SecureSocket>>accept (in category 'connect') ----- accept "Accept a connection from the receiver socket. Return a new socket that is connected to the client" ^self class acceptFrom: self.! ----- Method: SecureSocket>>certState (in category 'accessing') ----- certState ^ssl ifNotNil:[ssl certState]! ----- Method: SecureSocket>>decodeData (in category 'primitives') ----- decodeData "Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available." | total bytesRead | decoded atEnd ifFalse:[^self]. "Decrypt more data if available" bytesRead := 0. [total := ssl decrypt: readBuf from: 1 to: bytesRead into: decoded originalContents. total < 0 ifTrue:[^self error: 'SSL error, code: ', total]. bytesRead := 0. total = 0 ifTrue:[ bytesRead := super primSocket: socketHandle receiveDataInto: readBuf startingAt: 1 count: readBuf size. ]. bytesRead = 0] whileFalse. "Update for number of bytes decoded" decoded setFrom: 1 to: total. ! ----- Method: SecureSocket>>destroy (in category 'initialize') ----- destroy ssl ifNotNil:[ ssl destroy. ssl := nil ]. super destroy.! ----- Method: SecureSocket>>initialize (in category 'initialize') ----- initialize super initialize. decoded := ReadStream on: (ByteArray new: 20000) from: 1 to: 0. sendBuf := ByteArray new: 4096. readBuf := ByteArray new: 4096. ! ----- Method: SecureSocket>>isConnected (in category 'primitives') ----- isConnected "Return true if this socket is connected." "We mustn't return false if there is data available" ^super isConnected or:[self dataAvailable]! ----- Method: SecureSocket>>peerName (in category 'accessing') ----- peerName ^ssl ifNotNil:[ssl peerName]! ----- Method: SecureSocket>>primSocket:receiveDataInto:startingAt:count: (in category 'primitives') ----- primSocket: socketID receiveDataInto: buffer startingAt: index count: count "Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available." | total | ssl ifNil:[^super primSocket: socketID receiveDataInto: buffer startingAt: index count: count]. self decodeData. "Push data from decoded into the result buffer" total := (decoded size - decoded position) min: (buffer size - index + 1). (decoded readInto: buffer startingAt: index count: total) = total ifFalse:[self error: 'Unexpected read failure']. ^total ! ----- Method: SecureSocket>>primSocket:sendData:startIndex:count: (in category 'primitives') ----- primSocket: socketID sendData: buffer startIndex: start count: amount "Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed." "Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created." | count | ssl ifNil:[^super primSocket: socketID sendData: buffer startIndex: start count: amount]. count := ssl encrypt: buffer from: start to: start+amount-1 into: sendBuf. count < 0 ifTrue:[self error: 'SSL Error: ', count]. ^super primSocket: socketID sendData: sendBuf startIndex: 1 count: count! ----- Method: SecureSocket>>primSocketReceiveDataAvailable: (in category 'primitives') ----- primSocketReceiveDataAvailable: socketID "Return true if data may be available for reading from the current socket." ssl ifNil:[^super primSocketReceiveDataAvailable: socketID]. self decodeData. ^decoded atEnd not! ----- Method: SecureSocket>>ssl (in category 'accessing') ----- ssl "Answer the SqueakSSL instance" ^ssl! ----- Method: SecureSocket>>sslAccept: (in category 'connect') ----- sslAccept: certName "Perform the SSL server handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete." | squeakSSL result inbuf | inbuf := ''. squeakSSL := SqueakSSL new. squeakSSL certName: certName. "Perform the server handshake" [[squeakSSL isConnected] whileFalse:[ "Read input" inbuf := self receiveData. result := squeakSSL accept: inbuf from: 1 to: inbuf size into: sendBuf. "Check for errors first" result < -1 ifTrue:[^self error: 'SSL accept failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[self sendData: (sendBuf copyFrom: 1 to: result)]. ]. "We are connected. From here on, encryption will take place." ssl := squeakSSL. ] ifCurtailed:[ "Make sure we destroy the platform handle if the handshake gets interrupted" squeakSSL destroy. ]. ! ----- Method: SecureSocket>>sslConnect (in category 'connect') ----- sslConnect "Perform the SSL client handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete." self sslConnectTo: nil! ----- Method: SecureSocket>>sslConnectTo: (in category 'connect') ----- sslConnectTo: serverName "Perform the SSL client handshake. This method uses all the common SocketStream methods to adhere to the various timeout/signalling settings of SocketStream. It only installs the SSL instance after the handshake is complete. If serverName is not nil, then try to use it for SNI." | inbuf squeakSSL result | inbuf := ''. squeakSSL := SqueakSSL new. serverName ifNotNil: [ squeakSSL serverName: serverName ]. "Perform the SSL handshake" [[result := squeakSSL connect: inbuf from: 1 to: inbuf size into: sendBuf. result = 0] whileFalse:[ "Check for errors first" result < -1 ifTrue:[^self error: 'SSL connect failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[self sendData: (sendBuf copyFrom: 1 to: result)]. "Read more input and repeat" inbuf := self receiveData. ]. "We are connected. From here on, encryption will take place." ssl := squeakSSL. ] ifCurtailed:[ "Make sure we destroy the platform handle if the handshake gets interrupted" squeakSSL destroy. ]. ! Error subclass: #SqueakSSLCertificateError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-Core'! ----- Method: SqueakSSLCertificateError>>isResumable (in category 'testing') ----- isResumable "Determine whether an exception is resumable." ^true! Object subclass: #SqueakSSL instanceVariableNames: 'handle readBlock writeBlock' classVariableNames: '' poolDictionaries: '' category: 'SqueakSSL-Core'! !SqueakSSL commentStamp: 'ar 7/16/2010 23:14' prior: 0! SqueakSSL provides an interface to the platforms SSL/TLS facilities. ! ----- Method: SqueakSSL class>>checkCert: (in category 'utilities') ----- checkCert: certName "Attempt to verify the cert with the given name by performing an SSL handshake. Raises an error if there is an issue with the cert, returns the peer name from the cert if successful." | sslClient sslServer inbuf outbuf result | inbuf := ByteArray new: 4096. outbuf := ByteArray new: 4096. ["Perform the SSL handshake" sslClient := SqueakSSL new. sslServer := SqueakSSL new. sslServer certName: certName. result := 0. [result := sslClient connect: inbuf from: 1 to: result into: outbuf. result = 0] whileFalse:[ result < -1 ifTrue:[^self error: 'SSL handshake failed (client code: ', result, ')']. result := sslServer accept: outbuf from: 1 to: result into: inbuf. result < -1 ifTrue:[^self error: 'SSL handshake failed (server code: ', result, ')']. ]. "Handshake complete. Check the cert status" sslClient certState = 0 ifFalse:[ ^self error: 'Certificate validation failed (code: ', sslClient certState, ')'. ]. "When successful, just return the peer name to the caller" ^sslClient peerName ] ensure:[ sslClient ifNotNil:[sslClient destroy]. sslServer ifNotNil:[sslServer destroy]. ].! ----- Method: SqueakSSL class>>ensureSampleCert (in category 'examples') ----- ensureSampleCert "Ensure that we have a sample certificate for the tests" SqueakSSL platformName caseOf: { ['unix'] -> [^self ensureSampleCertFile]. ['Win32'] -> [^self ensureSampleCertInStore]. } otherwise: [^nil]. ! ----- Method: SqueakSSL class>>ensureSampleCertFile (in category 'examples') ----- ensureSampleCertFile "On Unix, we can simply create a valid cert file" | certName file | SqueakSSL platformName = 'unix' ifFalse:[^self]. certName := self name, 'Cert.pem'. (FileDirectory default fileExists: certName) ifFalse:[ file := FileDirectory default newFileNamed: certName. [file nextPutAll: self exampleCertFile withUnixLineEndings] ensure:[file close]. ]. ^FileDirectory default fullNameFor: certName. ! ----- Method: SqueakSSL class>>ensureSampleCertInStore (in category 'examples') ----- ensureSampleCertInStore "Ensure that we have a valid certificate in the Windows certificate store" SqueakSSL platformName = 'Win32' ifFalse:[^self]. "Undocumented. Allows importing a pfx w/o password. For the sole purpose of being able to run tests reliably" SqueakSSL new setStringProperty: 10001 to: self exampleCertPFX. ^'testcert'. "Friendly name of test cert" ! ----- Method: SqueakSSL class>>exampleCertFile (in category 'examples') ----- exampleCertFile ^'-----BEGIN RSA PRIVATE KEY----- MIICXQIBAAKBgQDnCv/gxDCb2yq15qkNwYtdMOHfW609Ck7wfwjVgzSNg+Hw+1R4 +krWhYRsWoXZUcy9xPC9WhnFCFijcnROcWp7vByVukFkVPYgzk1OBFT484ZCLBme 08GqLSzZrjgu7c1Yu5M9MZQdZKObBvZzDFsnvFccfM7G5mX/FgATasYaLQIDAQAB AoGBAMpUJ6B+LtNOKykAxir1w0Xo+OTRM/SwglC57tKMBAmp5MNUVbVb+w3B/yWk YHLf35yQSwKHVOnnVThNkuzfBY+MBxnaZwCByKknB4viP1ihPmfwdtqW4QXt1CTH 53sc9BVPjs3Nn1eEVrc582RK0MhORmjvlz+GkTswXCiKD3tBAkEA+6/au8T8XUeM y/KrtJ+U84seviw5nY93Yg7495n4ir1fojp4wFbWq1JTeM22zspZQOKzEsjxfHUi UH3buH//OwJBAOsAlJdIZqTIJponBXho+jqLHqcZYXBz3znDzHZU1PLfyfq2DuVe gt8UWa4VwlCZNtPi7g/iFPEcLOlf2XY3hbcCQFU7voVsNlKYknPW4JMwn87CREz+ yRw0o6dPjry7JdJGQ4a66n2oatZl8OKuN8Rb/lHc8+vepPkS6eX8WVZn8lUCQE2r F3EYgLQdYoS4ONqe93S53hukC8w6v6A70iuZxfevdvXhjfLI1cAc3bbngh1ZRgGp kry1H+7APSe0gg7MMukCQQD3jdsVoc4yhziMdpUMyw6R6vYCMJbMEr/tI6CJYBG4 lW+zdcLK2d6GNpZU80F49HOvxH4HMg1Qv+UUiuxT7jpG -----END RSA PRIVATE KEY----- -----BEGIN CERTIFICATE----- MIICxTCCAi6gAwIBAgIJAN/0HUpkM5dvMA0GCSqGSIb3DQEBBQUAMEwxCzAJBgNV BAYTAkdCMRIwEAYDVQQIEwlCZXJrc2hpcmUxEDAOBgNVBAcTB05ld2J1cnkxFzAV BgNVBAoTDk15IENvbXBhbnkgTHRkMB4XDTExMDYwNjE0MzcyMFoXDTEyMDYwNTE0 MzcyMFowTDELMAkGA1UEBhMCR0IxEjAQBgNVBAgTCUJlcmtzaGlyZTEQMA4GA1UE BxMHTmV3YnVyeTEXMBUGA1UEChMOTXkgQ29tcGFueSBMdGQwgZ8wDQYJKoZIhvcN AQEBBQADgY0AMIGJAoGBAOcK/+DEMJvbKrXmqQ3Bi10w4d9brT0KTvB/CNWDNI2D 4fD7VHj6StaFhGxahdlRzL3E8L1aGcUIWKNydE5xanu8HJW6QWRU9iDOTU4EVPjz hkIsGZ7TwaotLNmuOC7tzVi7kz0xlB1ko5sG9nMMWye8Vxx8zsbmZf8WABNqxhot AgMBAAGjga4wgaswHQYDVR0OBBYEFGFwXmx2B6FB25yKMBm6g884lB2xMHwGA1Ud IwR1MHOAFGFwXmx2B6FB25yKMBm6g884lB2xoVCkTjBMMQswCQYDVQQGEwJHQjES MBAGA1UECBMJQmVya3NoaXJlMRAwDgYDVQQHEwdOZXdidXJ5MRcwFQYDVQQKEw5N eSBDb21wYW55IEx0ZIIJAN/0HUpkM5dvMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcN AQEFBQADgYEAbjMF7YzNQGovKD4NRjsnnKzQnUCTw6UquY2Oz/5SeLcPfLm8DudF qppAjJjNpAgYC0yWoWcIxatYF/AsgGc2WL3hzI8oK7by6STfVi5RfLA6jS7lIDOv 4BUVsWZKADbEPsfiwed9b9MLLx8gpLLBrrr2rZpSyeDu4v16haV6wg8= -----END CERTIFICATE----- '! ----- Method: SqueakSSL class>>exampleCertPFX (in category 'examples') ----- exampleCertPFX ^ #[48 130 7 50 2 1 3 48 130 6 248 6 9 42 134 72 134 247 13 1 7 1 160 130 6 233 4 130 6 229 48 130 6 225 48 130 3 191 6 9 42 134 72 134 247 13 1 7 6 160 130 3 176 48 130 3 172 2 1 0 48 130 3 165 6 9 42 134 72 134 247 13 1 7 1 48 28 6 10 42 134 72 134 247 13 1 12 1 6 48 14 4 8 88 63 142 234 51 170 181 1 2 2 8 0 128 130 3 120 247 113 35 203 188 93 48 77 162 13 174 138 246 211 61 198 135 133 35 173 48 145 17 17 215 165 194 254 211 158 248 98 76 208 35 117 179 66 160 245 118 213 71 174 220 87 29 165 94 87 52 172 173 229 251 165 205 43 242 114 250 65 123 9 113 132 130 241 182 211 44 155 163 177 90 52 4 72 47 37 0 101 149 229 33 113 144 29 160 38 44 28 178 1 193 134 122 194 233 165 233 236 242 121 119 47 72 143 91 146 148 29 155 94 202 17 124 77 21 110 194 197 228 149 28 9 129 74 139 76 1 180 245 235 1 191 177 175 158 159 16 12 52 96 80 243 34 26 155 45 210 192 183 217 230 122 13 19 197 214 172 29 151 24 153 136 8 203 72 220 199 79 22 79 251 248 83 204 246 117 242 216 219 53 20 182 121 148 173 221 177 210 171 107 56 101 159 63 110 23 37 168 47 25 252 163 244 206 125 220 122 108 251 223 93 219 129 242 137 229 199 216 254 230 235 62 33 236 39 211 255 184 37 134 152 51 188 182 195 242 18 43 29 134 16 183 48 35 0 100 231 121 145 91 99 171 183 225 246 126 56 190 198 188 79 227 107 211 1 65 113 64 71 9 120 185 75 138 171 220 155 182 35 226 180 121 108 83 253 1 232 183 151 97 160 73 117 218 140 182 224 58 227 40 171 59 143 213 187 41 57 174 185 115 190 81 111 110 81 149 122 114 170 14 10 168 113 248 120 13 247 231 160 162 14 4 227 41 48 249 153 2 107 130 176 16 144 160 116 41 25 241 225 126 110 24 7 69 221 205 108 141 73 164 61 76 219 248 94 142 69 171 109 44 45 75 34 179 205 40 62 161 191 222 79 131 239 230 86 201 124 48 226 212 13 178 187 248 29 191 81 98 229 199 91 204 153 220 112 227 71 116 233 131 134 160 244 78 77 84 128 144 63 123 210 148 221 133 201 44 41 218 89 64 253 172 106 220 127 130 151 11 88 155 57 172 192 196 165 93 177 197 139 128 45 223 88 64 196 6 15 153 160 156 168 3 202 102 129 134 25 75 61 51 190 216 218 178 101 250 91 255 169 245 170 55 228 47 111 197 10 145 196 180 96 217 97 49 104 134 62 228 86 203 242 207 75 246 77 115 20 81 40 173 107 113 251 9 172 18 21 10 102 117 86 63 252 91 190 64 190 140 1 146 70 75 130 110 94 129 107 155 24 253 117 204 162 32 30 102 75 62 42 204 19 159 205 62 23 26 192 23 79 128 205 18 72 198 84 83 107 16 234 121 61 33 101 48 72 32 197 119 216 2 24 213 8 133 63 181 65 15 192 138 240 203 219 69 207 68 66 233 168 195 13 212 235 34 22 142 226 141 25 131 250 123 202 13 163 142 214 170 179 240 5 21 201 143 103 4 70 139 84 104 115 140 248 163 15 71 220 197 222 251 170 15 158 82 26 214 186 154 139 37 245 77 174 37 29 218 103 99 14 230 36 75 72 140 186 89 146 99 10 10 94 68 150 159 234 64 234 32 254 117 187 160 102 46 25 25 77 184 134 151 2 236 109 63 58 186 148 239 251 122 59 123 200 29 42 70 51 118 54 71 184 71 0 111 178 10 81 141 247 59 254 67 191 214 239 78 238 217 142 184 87 107 111 14 102 97 61 229 94 118 187 52 204 25 52 233 177 250 17 62 113 22 163 2 250 13 5 238 103 80 143 201 25 73 33 93 212 81 126 207 29 138 72 191 60 182 132 255 76 97 254 188 96 81 72 73 43 118 191 106 118 41 112 45 96 255 148 59 79 111 89 61 199 106 75 199 154 21 60 25 124 156 168 42 233 7 102 203 120 161 126 125 118 110 114 229 174 26 31 215 140 120 85 171 146 207 176 159 100 102 215 83 142 39 61 255 84 12 19 235 207 44 199 229 220 98 38 167 113 24 88 66 31 115 135 184 70 133 129 3 57 44 202 230 225 37 70 222 228 126 130 216 185 247 48 130 3 26 6 9 42 134 72 134 247 13 1 7 1 160 130 3 11 4 130 3 7 48 130 3 3 48 130 2 255 6 11 42 134 72 134 247 13 1 12 10 1 2 160 130 2 166 48 130 2 162 48 28 6 10 42 134 72 134 247 13 1 12 1 3 48 14 4 8 157 82 4 247 110 231 147 241 2 2 8 0 4 130 2 128 81 141 63 61 170 27 13 87 195 101 166 17 185 109 40 123 79 40 85 18 112 106 87 142 32 19 113 12 131 155 36 149 204 92 237 1 142 195 36 34 134 117 241 52 38 4 223 121 9 207 149 114 168 232 16 31 38 128 191 205 129 96 20 210 13 246 170 175 72 206 132 163 135 42 227 200 61 4 223 65 246 136 48 139 206 95 243 12 78 111 152 17 172 160 235 19 185 107 248 215 171 69 17 108 110 12 143 48 163 35 112 60 104 210 180 61 97 35 132 190 185 52 214 94 137 51 90 103 115 176 108 81 179 254 43 128 230 0 178 229 102 142 136 122 52 213 218 150 93 29 251 227 151 124 220 211 152 14 214 57 253 134 5 216 20 70 142 9 67 253 187 20 45 239 144 60 149 38 118 94 5 240 92 240 11 163 131 39 237 219 228 68 198 176 184 23 155 181 19 149 188 2 73 215 118 95 52 169 186 179 142 106 201 222 98 38 7 72 12 167 242 23 217 58 8 48 98 75 203 68 202 230 50 109 112 231 34 77 8 212 132 34 53 120 195 211 170 209 138 45 25 22 249 200 39 170 102 104 35 23 165 199 0 180 149 231 66 55 227 101 212 227 111 140 202 218 21 211 142 227 95 228 34 59 29 23 212 43 142 132 36 100 19 58 38 124 136 77 192 186 174 111 82 162 61 13 207 31 123 138 16 236 169 94 182 156 137 71 11 3 223 81 146 185 230 164 108 87 82 126 167 121 216 202 201 21 197 50 204 62 46 30 80 245 60 157 124 81 50 79 225 144 130 55 141 182 176 61 62 128 88 105 3 206 168 97 81 180 145 20 211 135 252 195 71 185 42 209 139 98 27 47 3 181 252 89 41 67 246 238 34 71 224 211 65 165 130 115 138 102 130 153 126 248 225 200 42 33 247 34 83 47 161 223 179 49 244 240 108 184 244 229 129 42 34 208 77 62 142 125 57 121 39 2 223 123 75 83 35 184 136 71 228 58 15 61 16 21 111 21 72 84 107 99 66 51 251 47 132 92 62 85 53 197 90 170 118 254 28 232 170 69 119 55 25 30 210 189 113 231 121 214 151 141 218 11 54 90 17 40 94 143 41 72 221 16 204 7 126 200 220 28 157 75 159 142 181 56 44 244 2 206 93 230 121 110 124 181 108 157 161 2 131 121 119 22 99 4 194 228 137 124 193 89 196 239 216 79 206 88 233 84 70 205 120 107 79 1 95 117 198 73 112 207 18 52 174 188 81 59 75 238 227 184 57 166 66 12 188 200 97 251 40 146 239 27 44 6 104 216 90 153 8 161 189 194 32 200 124 180 43 124 169 200 80 238 28 234 114 46 216 243 192 75 180 149 181 215 39 214 64 69 183 205 159 252 238 50 141 132 214 2 245 5 251 219 32 217 37 146 78 226 201 81 209 79 74 174 108 65 49 70 48 31 6 9 42 134 72 134 247 13 1 9 20 49 18 30 16 0 116 0 101 0 115 0 116 0 99 0 101 0 114 0 116 48 35 6 9 42 134 72 134 247 13 1 9 21 49 22 4 20 161 19 18 59 76 168 198 72 97 179 205 74 244 65 111 116 223 140 145 154 48 49 48 33 48 9 6 5 43 14 3 2 26 5 0 4 20 182 216 177 70 221 73 183 142 238 169 97 22 175 148 97 145 207 223 75 54 4 8 178 120 42 60 194 226 96 245 2 2 8 0]! ----- Method: SqueakSSL class>>google: (in category 'examples') ----- google: query "An example HTTPS query to encrypted.google.com. Example: SqueakSSL google: 'squeak'. SqueakSSL google: 'SqueakSSL'. " | hostName address socket ssl | "Change the host name to try an https request to some other host" hostName := 'encrypted.google.com'.. address := NetNameResolver addressForName: hostName. socket := Socket newTCP. "Connect the TCP socket" socket connectTo: address port: 443. socket waitForConnectionFor: 10. "Set up SqueakSSL using the convenience APIs" ssl := SqueakSSL on: socket. ["Let SqueakSSL handle the client handshake" ssl connect. "Verify that the cert is valid" ssl certState = 0 ifFalse:[ self error: 'The certificate is invalid (code: ', ssl certState,')'. ]. "If the certificate is valid, make sure we're were we wanted to go" (ssl peerName match: hostName) ifFalse:[ self error: 'Host name mismatch: ', ssl peerName. ]. "Send encrypted data" ssl sendData: 'GET /search?q=', query,' HTTP/1.0', String crlf, 'Host: ', hostName, String crlf, 'Connection: close', String crlf, String crlf. "Wait for the response" ^String streamContents:[:s| [socket isConnected | socket dataAvailable] whileTrue:[s nextPutAll: ssl receiveData]]. ] ensure:[ssl destroy]. ! ----- Method: SqueakSSL class>>on: (in category 'instance creation') ----- on: aSocket "Convenience API. Create a SqueakSSL operating on a standard TCP socket. Generally not very useful for real applications (it lacks error handling etc) but very helpful for debugging and other experiments." ^self new on: aSocket! ----- Method: SqueakSSL class>>platformName (in category 'utilities') ----- platformName "Return the name of the platform we're running on." ^Smalltalk getSystemAttribute: 1001! ----- Method: SqueakSSL class>>secureSocket (in category 'instance creation') ----- secureSocket "Answer the class to use as secure socket implementation. Provided here so that users only need a dependency on SqueakSSL." ^SecureSocket! ----- Method: SqueakSSL class>>secureSocketStream (in category 'instance creation') ----- secureSocketStream "Answer the class to use as secure socket stream implementation. Provided here so that users only need a dependency on SqueakSSL." ^SecureSocketStream! ----- Method: SqueakSSL class>>serverOn:certName: (in category 'examples') ----- serverOn: port certName: certName "An HTTPS server example. Fires up a listener at the given port such that you can point a browser to that https url. Responds with a single line of text and closes the listener after the first connection. SqueakSSL serverOn: 8443 certName: 'Internet Widgits Pty'. SqueakSSL serverOn: 8443 certName: '/home/andreas/certs/testcert.pem'. " | listener socket ssl | "Set up the listener socket" listener := Socket newTCP. listener listenOn: port backlogSize: 8. [socket := listener waitForAcceptFor: 30. socket == nil] whileTrue. listener destroy. "Set up SqueakSSL for the just accepted connection" [ssl := SqueakSSL on: socket. "The SSL needs the cert name." ssl certName: certName. "Let SqueakSSL do the server handshake" ssl accept. "Read out the HTTPS request" ssl receiveData. "And send the response" ssl sendData: 'HTTP/1.0 200 OK', String crlf, 'Connection: close', String crlf, 'Content-Type: text/plain', String crlf, 'Server: SqueakSSL', String crlf, String crlf, 'This is a successful SqueakSSL response.'. socket close. ] ensure:[ ssl destroy. socket destroy. ].! ----- Method: SqueakSSL>>accept (in category 'convenience') ----- accept "Convenience API. Perform an SSL server handshake. Raises an error if something goes wrong." | inbuf outbuf count result | inbuf := ByteArray new: 4096. outbuf := ByteArray new: 4096. count := 0. [self isConnected] whileFalse:[ "Read input" count := self readDataInto: inbuf. result := self accept: inbuf from: 1 to: count into: outbuf. "Check for errors first" result < -1 ifTrue:[^self error: 'SSL accept failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[self writeData: outbuf count: result]. ]. ! ----- Method: SqueakSSL>>accept:from:to:into: (in category 'operations') ----- accept: srcBuf from: start to: stop into: dstBuf "Start or continue the server handshake using the given input token." ^self primitiveSSL: handle accept: srcBuf startingAt: start count: stop-start+1 into: dstBuf! ----- Method: SqueakSSL>>certName (in category 'accessing') ----- certName "The name of the (local) certificate to provide to the remote peer." ^self primitiveSSL: handle getStringProperty: 1! ----- Method: SqueakSSL>>certName: (in category 'accessing') ----- certName: aString "Sets the name of the (local) certificate to provide to the remote peer. OpenSSL: The name is the full path to a .pem file. WinSSL: The name is matched against the 'friendly name' of a certificate in the cert store. " ^self primitiveSSL: handle setStringProperty: 1 toValue: (aString ifNil:[''])! ----- Method: SqueakSSL>>certState (in category 'accessing') ----- certState "Returns the certificate verification bits. The returned value indicates whether the certificate is valid. The two standard values are: 0 - The certificate is valid. -1 - No certificate has been provided by the peer. Otherwise, the result is a bit mask of the following values: 1 - If set, there is an unspecified issue with the cert (generic error) 2 - If set, the root CA is untrusted (usually a self-signed cert) 4 - If set, the certificate is expired. 8 - If set, the certificate is used for the wrong purpose 16 - If set, the CN of the certificate is invalid. 32 - If set, the certificate was revoked. " ^self primitiveSSL: handle getIntProperty: 3! ----- Method: SqueakSSL>>connect (in category 'convenience') ----- connect "Convenience API. Perform an SSL client handshake. Raises an error if something goes wrong." | inbuf outbuf count result | inbuf := ByteArray new: 4096. outbuf := ByteArray new: 4096. count := 0. "Begin the SSL handshake" [result := self connect: inbuf from: 1 to: count into: outbuf. result = 0] whileFalse:[ "Check for errors first" result < -1 ifTrue:[^self error: 'SSL connect failed with code: ', result]. "If a token has been produced in the handshake, send it to the remote" result > 0 ifTrue:[self writeData: outbuf count: result]. "Read more input and repeat" count := self readDataInto: inbuf. ].! ----- Method: SqueakSSL>>connect:from:to:into: (in category 'operations') ----- connect: srcBuf from: start to: stop into: dstBuf "Start or continue the server handshake using the given input token." ^self primitiveSSL: handle connect: srcBuf startingAt: start count: stop-start+1 into: dstBuf! ----- Method: SqueakSSL>>decrypt: (in category 'convenience') ----- decrypt: data "Convenience API. Decrypt incoming data and return the result. Warning: This method may produce more or less results than expected unless called with exactly one SSL/TLS frame." | buf count | buf := data class new: 4096. count := self decrypt: data from: 1 to: data size into: buf. count < 0 ifTrue:[self error: 'Decryption failed, code: ', count]. ^buf copyFrom: 1 to: count! ----- Method: SqueakSSL>>decrypt:from:to:into: (in category 'operations') ----- decrypt: srcBuf from: start to: stop into: dstBuf "Decrypt the input in srcBuf into the provided output buffer. Clients are expected to adhere to the following rules: * The size of dstBuf must be large enough for the largest encrypted packet. * Clients must not call this method with a huge srcBuf (tens of kb of data) * After having called this method with new input, clients must call it with NO input until all data has been 'drained' for example: count := squeakSSL decrypt: srcBuf into: dstBuf. [count > 0] whileTrue:[ count := squeakSSL decrypt: #[] into: dstBuf. ]. " ^self primitiveSSL: handle decrypt: srcBuf startingAt: start count: stop-start+1 into: dstBuf! ----- Method: SqueakSSL>>destroy (in category 'initialize') ----- destroy "Destroys the underlying platform handle" handle ifNotNil:[ self primitiveSSLDestroy: handle. handle := nil. ].! ----- Method: SqueakSSL>>encrypt: (in category 'convenience') ----- encrypt: data "Convenience API. Encrypt incoming data and return the result." | buf count | buf := data class new: data size + 100. count := self encrypt: data from: 1 to: data size into: buf. count < 0 ifTrue:[self error: 'Decryption failed, code: ', count]. ^buf copyFrom: 1 to: count! ----- Method: SqueakSSL>>encrypt:from:to:into: (in category 'operations') ----- encrypt: srcBuf from: start to: stop into: dstBuf "Encrypt the input in srcBuf into the provided output buffer. The output buffer must be large enough to include the framing information." ^self primitiveSSL: handle encrypt: srcBuf startingAt: start count: stop-start+1 into: dstBuf! ----- Method: SqueakSSL>>initialize (in category 'initialize') ----- initialize "Initialize the receiver" handle := self primitiveSSLCreate. ! ----- Method: SqueakSSL>>isConnected (in category 'testing') ----- isConnected "Returns true if the SSL handshake has been completed" ^self sslState = 3! ----- Method: SqueakSSL>>logLevel (in category 'accessing') ----- logLevel "Returns the log level of the ssl instance" ^self primitiveSSL: handle getIntProperty: 1! ----- Method: SqueakSSL>>logLevel: (in category 'accessing') ----- logLevel: aNumber "Sets the log level of the ssl instance" ^self primitiveSSL: handle setIntProperty: 1 toValue: aNumber! ----- Method: SqueakSSL>>on: (in category 'initialize') ----- on: aSocket "Convenience API. Set up SqueakSSL to operate on a standard TCP socket. Generally not very useful for real applications (it lacks error handling etc) but very helpful for debugging and other experiments." self readBlock:[:inbuf| aSocket waitForDataIfClosed:[]. aSocket receiveDataInto: inbuf. ]. self writeBlock:[:outbuf :count| aSocket sendData: (outbuf copyFrom: 1 to: count). ].! ----- Method: SqueakSSL>>peerName (in category 'accessing') ----- peerName "Returns the certificate name of the remote peer. The method only returns a name if the certificate has been verified." ^self primitiveSSL: handle getStringProperty: 0! ----- Method: SqueakSSL>>pluginVersion (in category 'accessing') ----- pluginVersion "Returns the version of the plugin" ^self primitiveSSL: handle getIntProperty: 0! ----- Method: SqueakSSL>>primitiveSSL:accept:startingAt:count:into: (in category 'primitives') ----- primitiveSSL: sslHandle accept: srcbuf startingAt: start count: length into: dstbuf "Primitive. Starts or continues a server handshake using the provided data. Will eventually produce output to be sent to the server. Returns: > 0 - Number of bytes to be sent to the server 0 - Success. The connection is established. -1 - More input is required. < -1 - Other errors " ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:connect:startingAt:count:into: (in category 'primitives') ----- primitiveSSL: sslHandle connect: srcbuf startingAt: start count: length into: dstbuf "Primitive. Starts or continues a client handshake using the provided data. Will eventually produce output to be sent to the server. Returns: > 0 - Number of bytes to be sent to the server 0 - Success. The connection is established. -1 - More input is required. < -1 - Other errors " ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:decrypt:startingAt:count:into: (in category 'primitives') ----- primitiveSSL: sslHandle decrypt: srcbuf startingAt: start count: length into: dstbuf "Primitive. Takes incoming data for decryption and continues to decrypt data. Returns the number of bytes produced in the output" ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:encrypt:startingAt:count:into: (in category 'primitives') ----- primitiveSSL: sslHandle encrypt: srcbuf startingAt: start count: length into: dstbuf "Primitive. Encrypts the incoming buffer into the result buffer. Returns the number of bytes produced as a result." ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:getIntProperty: (in category 'primitives') ----- primitiveSSL: sslHandle getIntProperty: propID "Primitive. Returns a string property from an SSL session." ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:getStringProperty: (in category 'primitives') ----- primitiveSSL: sslHandle getStringProperty: propID "Primitive. Returns a string property from an SSL session." ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:setIntProperty:toValue: (in category 'primitives') ----- primitiveSSL: sslHandle setIntProperty: propID toValue: anInteger "Primitive. Sets a string property in an SSL session." ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSL:setStringProperty:toValue: (in category 'primitives') ----- primitiveSSL: sslHandle setStringProperty: propID toValue: aString "Primitive. Sets a string property in an SSL session." ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSLCreate (in category 'primitives') ----- primitiveSSLCreate "Primitive. Creates and returns a new SSL handle" ^self primitiveFailed! ----- Method: SqueakSSL>>primitiveSSLDestroy: (in category 'primitives') ----- primitiveSSLDestroy: sslHandle "Primitive. Destroys the SSL session handle" ^self primitiveFailed! ----- Method: SqueakSSL>>readBlock (in category 'accessing') ----- readBlock "The block used to read data where required. The block takes one argument, the buffer to fill with data and is expected to return the number of bytes read." ^readBlock! ----- Method: SqueakSSL>>readBlock: (in category 'accessing') ----- readBlock: aBlock "The block used to read data where required. The block takes one argument, the buffer to fill with data and is expected to return the number of bytes read." readBlock := aBlock! ----- Method: SqueakSSL>>readDataInto: (in category 'private') ----- readDataInto: aBuffer "Private. Read actual data into the given buffer. Return the number of bytes read." ^readBlock value: aBuffer! ----- Method: SqueakSSL>>receiveData (in category 'convenience') ----- receiveData "Convenience API. Receive data and decrypt it." | inbuf outbuf count | inbuf := String new: 4096. outbuf := String new: 4096. ^String streamContents:[:s| "Read the next input bytes" count := self readDataInto: inbuf. "Push the input bytes into the SSL" count := self decrypt: inbuf from: 1 to: count into: outbuf. "And keep draining as long as output is being produced" [count > 0] whileTrue:[ s next: count putAll: outbuf. count := self decrypt: inbuf from: 1 to: 0 into: outbuf. ]. ].! ----- Method: SqueakSSL>>sendData: (in category 'convenience') ----- sendData: inbuf "Convenience API. Encrypt and send data" | outbuf count | outbuf := inbuf class new: inbuf size + 100. count := self encrypt: inbuf from: 1 to: inbuf size into: outbuf. ^self writeData: outbuf count: count.! ----- Method: SqueakSSL>>serverName: (in category 'accessing') ----- serverName: aString "Sets the name to use with the Server Name Indication TLS extension. Which should be a valid FQDN. No WinSSL support yet." ^[ self primitiveSSL: handle setStringProperty: 2 toValue: aString ] on: Error do: [ "nothing" ]! ----- Method: SqueakSSL>>setStringProperty:to: (in category 'private') ----- setStringProperty: index to: aString "Private. Use with caution" ^self primitiveSSL: handle setStringProperty: index toValue: aString! ----- Method: SqueakSSL>>sslState (in category 'accessing') ----- sslState "Returns the current state of the SSL connection: 0 - Unused. 1 - In accept handshake. 2 - In connect handshake. 3 - Connected. " ^self primitiveSSL: handle getIntProperty: 2 ! ----- Method: SqueakSSL>>writeBlock (in category 'accessing') ----- writeBlock "The block used to write data where required. The block takes two arguments, the buffer and the number of bytes to be written from the buffer." ^writeBlock! ----- Method: SqueakSSL>>writeBlock: (in category 'accessing') ----- writeBlock: aBlock "The block used to write data where required. The block takes two arguments, the buffer and the number of bytes to be written from the buffer." writeBlock := aBlock! ----- Method: SqueakSSL>>writeData:count: (in category 'private') ----- writeData: aBuffer count: count "Private. Write actual data from the given buffer." writeBlock value: aBuffer value: count! From commits at source.squeak.org Fri Jun 5 20:19:38 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:19:42 2015 Subject: [squeak-dev] Squeak 4.6: CommandLine-cmm.4.mcz Message-ID: Chris Muller uploaded a new version of CommandLine to project Squeak 4.6: http://source.squeak.org/squeak46/CommandLine-cmm.4.mcz ==================== Summary ==================== Name: CommandLine-cmm.4 Author: cmm Time: 16 January 2015, 3:27:43.102 pm UUID: 0a2ab805-2910-49f5-81dc-c7de4581f4f6 Ancestors: CommandLine-fbs.3 Let Errors print themselves. ==================== Snapshot ==================== SystemOrganization addCategory: #'CommandLine-Tools'! SystemOrganization addCategory: #'CommandLine-UIManager'! UIManager subclass: #DummyUIManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CommandLine-UIManager'! !DummyUIManager commentStamp: 'fbs 10/31/2013 07:36' prior: 0! I'm an alternative UIManager used to run an the image without GUI. I redefine methods which require user input as these requests are irrelevant in a headless environment. ! ----- Method: DummyUIManager>>checkForNewDisplaySize (in category 'display') ----- checkForNewDisplaySize Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. DisplayScreen startUp. ! ----- Method: DummyUIManager>>chooseDirectory:from: (in category 'ui requests') ----- chooseDirectory: label from: dir ^ nil! ----- Method: DummyUIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray title: aString ^ aList first! ----- Method: DummyUIManager>>chooseFrom:values:lines:title: (in category 'ui requests') ----- chooseFrom: labelList values: valueList lines: linesArray title: aString ^ valueList first! ----- Method: DummyUIManager>>confirm: (in category 'ui requests') ----- confirm: queryString (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer|^answer]. self error: 'No user response possible'! ----- Method: DummyUIManager>>confirm:orCancel: (in category 'ui requests') ----- confirm: aString orCancel: cancelBlock (ProvideAnswerNotification signal: aString) ifNotNil: [:answer | ^answer == #cancel ifTrue: [cancelBlock value] ifFalse: [answer]]. self error: 'No user response possible'! ----- Method: DummyUIManager>>displayProgress:at:from:to:during: (in category 'ui requests') ----- displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock ^ workBlock value: Association new! ----- Method: DummyUIManager>>edit:label:accept: (in category 'ui requests') ----- edit: aText label: labelString accept: anAction ^ nil! ----- Method: DummyUIManager>>fontFromUser: (in category 'ui requests') ----- fontFromUser: priorFont self error: 'No user response possible'! ----- Method: DummyUIManager>>inform: (in category 'ui requests') ----- inform: aString "Nothing to be done here"! ----- Method: DummyUIManager>>informUserDuring: (in category 'ui requests') ----- informUserDuring: aBlock aBlock value: nil! ----- Method: DummyUIManager>>newDisplayDepthNoRestore: (in category 'display') ----- newDisplayDepthNoRestore: pixelSize "Change depths. Check if there is enough space!! , di" | area need | pixelSize = Display depth ifTrue: [^ self "no change"]. pixelSize abs < Display depth ifFalse: ["Make sure there is enough space" area := Display boundingBox area. "pixels" need := (area * (pixelSize abs - Display depth) // 8) "new bytes needed" + Smalltalk lowSpaceThreshold. (Smalltalk garbageCollectMost <= need and: [Smalltalk garbageCollect <= need]) ifTrue: [self error: 'Insufficient free space']]. Display setExtent: Display extent depth: pixelSize. DisplayScreen startUp! ----- Method: DummyUIManager>>request:initialAnswer: (in category 'ui requests') ----- request: queryString initialAnswer: defaultAnswer (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^ answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]]. self error: 'No user response possible'! ----- Method: DummyUIManager>>requestPassword: (in category 'ui requests') ----- requestPassword: queryString ^ self request: queryString initialAnswer: ''! ----- Method: DummyUIManager>>restoreDisplay (in category 'display') ----- restoreDisplay! ----- Method: DummyUIManager>>restoreDisplayAfter: (in category 'display') ----- restoreDisplayAfter: aBlock aBlock value. Sensor waitButton.! StandardToolSet subclass: #CommandLineToolSet instanceVariableNames: '' classVariableNames: 'SaveSnapshotOnError' poolDictionaries: '' category: 'CommandLine-Tools'! ----- Method: CommandLineToolSet class>>debugContext:label:contents: (in category 'debugging') ----- debugContext: aContext label: aString contents: contents "We can't open a command line debugger, so just log the error and carry on." | s | s := FileStream stderr. s nextPutAll: self className; nextPutAll: ': '; nextPutAll: aString; cr; nextPutAll: contents; cr. (aContext stackOfSize: 20) do: [:ctx | ctx printOn: s. s cr]. s flush.! ----- Method: CommandLineToolSet class>>debugError: (in category 'debugging') ----- debugError: anError "Print out a sensible stack trace and bail" self saveSnapshotOnError ifTrue: [ Smalltalk saveAs: 'Debug-' , Smalltalk imageEntry name ]. anError printVerboseOn: FileStream stderr. FileStream stderr flush. Smalltalk snapshot: false andQuit: true! ----- Method: CommandLineToolSet class>>debugSyntaxError: (in category 'debugging') ----- debugSyntaxError: anError FileStream stderr nextPutAll: '----- Syntax error -----' ; cr ; nextPutAll: anError errorCode ; cr ; nextPutAll: '----- Syntax error -----' ; cr ; flush. self debugError: anError! ----- Method: CommandLineToolSet class>>saveSnapshotOnError (in category 'preferences') ----- saveSnapshotOnError ^ SaveSnapshotOnError ifNil: [SaveSnapshotOnError := false].! ----- Method: CommandLineToolSet class>>saveSnapshotOnError: (in category 'preferences') ----- saveSnapshotOnError: aBoolean SaveSnapshotOnError := aBoolean.! ----- Method: CommandLineToolSet class>>unload (in category 'class initialization') ----- unload ToolSet unregister: self.! From commits at source.squeak.org Fri Jun 5 20:19:46 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:19:49 2015 Subject: [squeak-dev] Squeak 4.6: Help-Squeak-TerseGuide-kfr.5.mcz Message-ID: Chris Muller uploaded a new version of Help-Squeak-TerseGuide to project Squeak 4.6: http://source.squeak.org/squeak46/Help-Squeak-TerseGuide-kfr.5.mcz ==================== Summary ==================== Name: Help-Squeak-TerseGuide-kfr.5 Author: kfr Time: 7 May 2015, 9:38:42.385 am UUID: 75a587af-6dbb-ee4b-b469-ad18259f34f8 Ancestors: Help-Squeak-TerseGuide-dhn.4 Expanded Rectangle guide a little ==================== Snapshot ==================== SystemOrganization addCategory: #'Help-Squeak-TerseGuide'! CustomHelp subclass: #TerseGuideHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Help-Squeak-TerseGuide'! !TerseGuideHelp commentStamp: 'dtl 11/26/2010 12:17' prior: 0! TerseGuideHelp contains the Squeak terse guide by Chris Rathman (http://www.angelfire.com/tx4/cus/notes/smalltalk.html), maintained on the swiki at http://wiki.squeak.org/squeak/5699. Copyrights and credit for the original document belong to Chris Rathman. The original document was formatted for printing with a fixed font. Here it is reformatted for display in a help browser, with various updates and corrections to match the current state of the Squeak image. The contents of the help pages may be evaluated as workspace expressions. HelpBrowser openOn: TerseGuideHelp ! ----- Method: TerseGuideHelp class>>arithmetic (in category 'pages') ----- arithmetic ^HelpTopic title: 'Arithmetic Expressions' contents: '"************************************************************************ * Arithmetic expressions: * ************************************************************************" | x | x := 6 + 3. "addition" x := 6 - 3. "subtraction" x := 6 * 3. "multiplication" x := 1 + 2 * 3. "evaluation always left to right (1 + 2) * 3" x := 5 / 3. "division with fractional result" x := 5.0 / 3.0. "division with float result" x := 5.0 // 3.0. "integer divide" x := 5.0 \\ 3.0. "integer remainder" x := -5. "unary minus" x := 5 sign. "numeric sign (1, -1 or 0)" x := 5 negated. "negate receiver" x := 1.2 integerPart. "integer part of number (1.0)" x := 1.2 fractionPart. "fractional part of number (0.2)" x := 5 reciprocal. "reciprocal function" x := 6 * 3.1. "auto convert to float" x := 5 squared. "square function" x := 25 sqrt. "square root" x := 5 raisedTo: 2. "power function" x := 5 raisedToInteger: 2. "power function with integer" x := 5 exp. "exponential" x := -5 abs. "absolute value" x := 3.99 rounded. "round" x := 3.99 truncated. "truncate" x := 3.99 roundTo: 1. "round to specified decimal places" x := 3.99 truncateTo: 1. "truncate to specified decimal places" x := 3.99 floor. "truncate" x := 3.99 ceiling. "round up" x := 5 factorial. "factorial" x := -5 quo: 3. "integer divide rounded toward zero" x := -5 rem: 3. "integer remainder rounded toward zero" x := 28 gcd: 12. "greatest common denominator" x := 28 lcm: 12. "least common multiple" x := 100 ln. "natural logarithm" x := 100 log. "base 10 logarithm" x := 100 log: 10 . "logarithm with specified base" x := 100 floorLog: 10. "floor of the log" x := 180 degreesToRadians. "convert degrees to radians" x := 3.14 radiansToDegrees. "convert radians to degrees" x := 0.7 sin. "sine" x := 0.7 cos. "cosine" x := 0.7 tan. "tangent" x := 0.7 arcSin. "arcsine" x := 0.7 arcCos. "arccosine" x := 0.7 arcTan. "arctangent" x := 10 max: 20. "get maximum of two numbers" x := 10 min: 20. "get minimum of two numbers" x := Float pi. "pi" x := Float e. "exp constant" x := Float infinity. "infinity" x := Float nan. "not-a-number" x := Random new next; yourself. x next. "random number stream (0.0 to 1.0)" x := 100 atRandom. "quick random number" '! ----- Method: TerseGuideHelp class>>array (in category 'pages') ----- array ^HelpTopic title: 'Array' contents: '"************************************************************************ * Array: Fixed length collection * * ByteArray: Array limited to byte elements (0-255) * * WordArray: Array limited to word elements (0-2^32) * ************************************************************************" | b x y sum max | x := #(4 3 2 1). "constant array" x := Array with: 5 with: 4 with: 3 with: 2. "create array with up to 4 elements" x := Array new: 4. "allocate an array with specified size" x "set array elements" at: 1 put: 5; at: 2 put: 4; at: 3 put: 3; at: 4 put: 2. b := x isEmpty. "test if array is empty" y := x size. "array size" y := x at: 4. "get array element at index" b := x includes: 3. "test if element is in array" y := x copyFrom: 2 to: 4. "subarray" y := x indexOf: 3 ifAbsent: [0]. "first position of element within array" y := x occurrencesOf: 3. "number of times object in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the array" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" y := x findFirst: [:a | a < 3]. "find position of first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum array elements" sum := 0. 1 to: (x size) do: [:a | sum := sum + (x at: a)]. "sum array elements" sum := x inject: 0 into: [:a :c | a + c]. "sum array elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in array" ifTrue: [a] ifFalse: [c]]. y := x shuffled. "randomly shuffle collection" y := x asArray. "convert to array" y := x asByteArray. "convert to byte array" y := x asWordArray. "convert to word array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>assignment (in category 'pages') ----- assignment ^HelpTopic title: 'Assignment' contents: '"************************************************************************ * Assignment: * ************************************************************************" | x y z | x _ 4. "assignment (Squeak) <-" x := 5. "assignment" x := y := z := 6. "compound assignment" x := (y := 6) + 1. x := Object new. "bind to allocated instance of a class" x := 123 class. "discover the object class" x := Integer superclass. "discover the superclass of a class" x := Object allInstances. "get an array of all instances of a class" x := Integer allSuperclasses. "get all superclasses of a class" x := 1.2 hash. "hash value for object" y := x copy. "copy object" y := x shallowCopy. "copy object (not overridden)" y := x deepCopy. "copy object and instance vars" y := x veryDeepCopy. "complete tree copy using a dictionary" '! ----- Method: TerseGuideHelp class>>association (in category 'pages') ----- association ^HelpTopic title: 'Association' contents: '"************************************************************************ * Associations: * ************************************************************************" | x y | x := #myVar->''hello''. y := x key. y := x value. '! ----- Method: TerseGuideHelp class>>bag (in category 'pages') ----- bag ^HelpTopic title: 'Bag' contents: '"************************************************************************ * Bag: like OrderedCollection except elements are in no * * particular order * ************************************************************************" | b x y sum max | x := Bag with: 4 with: 3 with: 2 with: 1. "create collection with up to 4 elements" x := Bag new. "allocate collection" x add: 4; add: 3; add: 1; add: 2; yourself. "add element to collection" x add: 3 withOccurrences: 2. "add multiple copies to collection" y := x addAll: #(7 8 9). "add multiple elements to collection" y := x removeAll: #(7 8 9). "remove multiple elements from collection" y := x remove: 4 ifAbsent: []. "remove element from collection" b := x isEmpty. "test if empty" y := x size. "number of elements" b := x includes: 3. "test if element is in collection" y := x occurrencesOf: 3. "number of times object in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the collection" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>bitwise (in category 'pages') ----- bitwise ^HelpTopic title: 'Bitwise Manipulation' contents: '"************************************************************************ * Bitwise Manipulation: * ************************************************************************" | b x | x := 16rFF bitAnd: 16r0F. "and bits" x := 16rF0 bitOr: 16r0F. "or bits" x := 16rFF bitXor: 16r0F. "xor bits" x := 16rFF bitInvert. "invert bits" x := 16r0F bitShift: 4. "left shift" x := 16rF0 bitShift: -4. "right shift" x := 16r80 bitAt: 8. "bit at position (0|1)" x := 16r80 highBit. "position of highest bit set" b := 16rFF allMask: 16r0F. "test if all bits set in mask set in receiver" b := 16rFF anyMask: 16r0F. "test if any bits set in mask set in receiver" b := 16rFF noMask: 16r0F. "test if all bits set in mask clear in receiver" '! ----- Method: TerseGuideHelp class>>block (in category 'pages') ----- block ^HelpTopic title: 'Blocks' contents: '"************************************************************************ * Blocks: * * - blocks are objects and may be assigned to a variable * * - value is last expression evaluated unless explicit return * * - blocks may be nested * * - specification [ arguments | | localvars | expressions ] * * - ^expression terminates block & method (exits all nested blocks) * * - blocks intended for long term storage should not contain ^ * ************************************************************************" | x y z fac | x := [ y := 1. z := 2. ]. x value. "simple block usage" x := [ :argOne :argTwo | argOne, '' and '' , argTwo.]. "set up block with argument passing" Transcript show: (x value: ''First'' value: ''Second''); cr. "use block with argument passing" x := [:e | | v | v := 1. e + v] value: 2. "localvar in a block" fac := [ :n | n > 1 ifTrue: [n * (fac value: n-1)] ifFalse: [1]]. "closure on block variable" fac value: 5. "closure variable scoped to its block" '! ----- Method: TerseGuideHelp class>>bookName (in category 'accessing') ----- bookName ^'Terse Guide'! ----- Method: TerseGuideHelp class>>boolean (in category 'pages') ----- boolean ^HelpTopic title: 'Boolean' contents: '"************************************************************************ * Booleans: * ************************************************************************" | b x y | x := 1. y := 2. b := (x = y). "equals" b := (x ~= y). "not equals" b := (x == y). "identical" b := (x ~~ y). "not identical" b := (x > y). "greater than" b := (x < y). "less than" b := (x >= y). "greater than or equal" b := (x <= y). "less than or equal" b := b not. "boolean not" b := (x < 5) & (y > 1). "boolean and" b := (x < 5) | (y > 1). "boolean or" b := (x < 5) and: [y > 1]. "boolean and (short-circuit)" b := (x < 5) or: [y > 1]. "boolean or (short-circuit)" b := (x < 5) eqv: (y > 1). "test if both true or both false" b := (x < 5) xor: (y > 1). "test if one true and other false" b := 5 between: 3 and: 12. "between (inclusive)" b := 123 isKindOf: Number. "test if object is class or subclass of" b := 123 isMemberOf: SmallInteger. "test if object is type of class" b := 123 respondsTo: #sqrt. "test if object responds to message" b := x isNil. "test if object is nil" b := x isZero. "test if number is zero" b := x positive. "test if number is positive" b := x strictlyPositive. "test if number is greater than zero" b := x negative. "test if number is negative" b := x even. "test if number is even" b := x odd. "test if number is odd" b := x isLiteral. "test if literal constant" b := x isInteger. "test if object is integer" b := x isFloat. "test if object is float" b := x isNumber. "test if object is number" b := $A isUppercase. "test if upper case character" b := $A isLowercase. "test if lower case character" '! ----- Method: TerseGuideHelp class>>character (in category 'pages') ----- character ^HelpTopic title: 'Character' contents: '"************************************************************************ * Character: * ************************************************************************" | x y b | x := $A. "character assignment" y := x isLowercase. "test if lower case" y := x isUppercase. "test if upper case" y := x isLetter. "test if letter" y := x isDigit. "test if digit" y := x isAlphaNumeric. "test if alphanumeric" y := x isSeparator. "test if seperator char" y := x isVowel. "test if vowel" y := x digitValue. "convert to numeric digit value" y := x asLowercase. "convert to lower case" y := x asUppercase. "convert to upper case" y := x asciiValue. "convert to numeric ascii value" y := x asString. "convert to string" b := $A <= $B. "comparison" y := $A max: $B. '! ----- Method: TerseGuideHelp class>>conditionalStatement (in category 'pages') ----- conditionalStatement ^HelpTopic title: 'Conditional Statement' contents: '"************************************************************************ * Conditional Statements: * ************************************************************************" | x switch result | x := 11. x > 10 ifTrue: [Transcript show: ''ifTrue''; cr]. "if then" x > 10 ifFalse: [Transcript show: ''ifFalse''; cr]. "if else" x > 10 "if then else" ifTrue: [Transcript show: ''ifTrue''; cr] ifFalse: [Transcript show: ''ifFalse''; cr]. x > 10 "if else then" ifFalse: [Transcript show: ''ifFalse''; cr] ifTrue: [Transcript show: ''ifTrue''; cr]. Transcript show: (x > 10 ifTrue: [''ifTrue''] ifFalse: [''ifFalse'']); cr. Transcript "nested if then else" show: (x > 10 ifTrue: [x > 5 ifTrue: [''A''] ifFalse: [''B'']] ifFalse: [''C'']); cr. switch := Dictionary new. "switch functionality" switch at: $A put: [Transcript show: ''Case A''; cr]. switch at: $B put: [Transcript show: ''Case B''; cr]. switch at: $C put: [Transcript show: ''Case C''; cr]. result := (switch at: $B) value. '! ----- Method: TerseGuideHelp class>>constants (in category 'pages') ----- constants ^HelpTopic title: 'Constants' contents: '"************************************************************************ * Constants: * ************************************************************************" | b x | b := true. "true constant" b := false. "false constant" x := nil. "nil object constant" x := 1. "integer constants" x := 3.14. "float constants" x := 2e-2. "fractional constants" x := 16r0F. "hex constant". x := -1. "negative constants" x := ''Hello''. "string constant" x := ''I''''m here''. "single quote escape" x := $A. "character constant" x := $ . "character constant (space)" x := #aSymbol. "symbol constants" x := #(3 2 1). "array constants" x := #(''abc'' 2 $a). "mixing of types allowed" '! ----- Method: TerseGuideHelp class>>conversion (in category 'pages') ----- conversion ^HelpTopic title: 'Conversion' contents: '"************************************************************************ * Conversion: * ************************************************************************" | x | x := 3.99 asInteger. "convert number to integer (truncates in Squeak)" x := 3.99 asFraction. "convert number to fraction" x := 3 asFloat. "convert number to float" x := 65 asCharacter. "convert integer to character" x := $A asciiValue. "convert character to integer" x := 3.99 printString. "convert object to string via printOn:" x := 3.99 storeString. "convert object to string via storeOn:" x := 15 radix: 16. "convert to string in given base" x := 15 printStringBase: 16. x := 15 storeStringBase: 16. '! ----- Method: TerseGuideHelp class>>date (in category 'pages') ----- date ^HelpTopic title: 'Date' contents: '"************************************************************************ * Date: * ************************************************************************" | x y b | x := Date today. "create date for today" x := Date dateAndTimeNow. "create date from current time/date" x := Date readFromString: ''01/02/1999''. "create date from formatted string" x := Date newDay: 12 month: #July year: 1999. "create date from parts" x := Date fromDays: 36000. "create date from elapsed days since 1/1/1901" y := Date dayOfWeek: #Monday. "day of week as int (1-7)" y := Date indexOfMonth: #January. "month of year as int (1-12)" y := Date daysInMonth: 2 forYear: 1996. "day of month as int (1-31)" y := Date daysInYear: 1996. "days in year (365|366)" y := Date nameOfDay: 1. "weekday name (#Monday,...)" y := Date nameOfMonth: 1. "month name (#January,...)" y := Date leapYear: 1996. "1 if leap year; 0 if not leap year" y := x weekday. "day of week (#Monday,...)" y := x previous: #Monday. "date for previous day of week" y := x dayOfMonth. "day of month (1-31)" y := x day. "day of year (1-366)" y := x firstDayOfMonth. "day of year for first day of month" y := x monthName. "month of year (#January,...)" y := x monthIndex. "month of year (1-12)" y := x daysInMonth. "days in month (1-31)" y := x year. "year (19xx)" y := x daysInYear. "days in year (365|366)" y := x daysLeftInYear. "days left in year (364|365)" y := x asSeconds. "seconds elapsed since 1/1/1901" y := x addDays: 10. "add days to date object" y := x subtractDays: 10. "subtract days to date object" y := x subtractDate: (Date today). "subtract date (result in days)" y := x printFormat: #(2 1 3 $/ 1 1). "print formatted date" b := (x <= Date today). "comparison" '! ----- Method: TerseGuideHelp class>>debugging (in category 'pages') ----- debugging ^HelpTopic title: 'Debugging' contents: '"************************************************************************ * debugging: * ************************************************************************" | a b x | x := Object new. x yourself. "returns receiver" String browse. "browse specified class" x inspect. "open object inspector window" x confirm: ''Is this correct?''. x halt. "breakpoint to open debugger window" x halt: ''Halt message''. x notify: ''Notify text''. x error: ''Error string''. "open up error window with title" x shouldNotImplement. "flag message should not be implemented" x subclassResponsibility. "flag message as abstract" x errorImproperStore. "flag an improper store into indexable object" x errorNonIntegerIndex. "flag only integers should be used as index" x errorSubscriptBounds: 13. "flag subscript out of bounds" x primitiveFailed. "system primitive failed" a := ''A1''. b := ''B2''. a become: b. "switch two objects" Transcript show: a, b; cr. x doesNotUnderstand: (Message selector: #foo). "flag message is not handled" '! ----- Method: TerseGuideHelp class>>dictionary (in category 'pages') ----- dictionary ^HelpTopic title: 'Dictionary' contents: '"************************************************************************ * Dictionary: * * IdentityDictionary: uses identity test (== rather than =) * ************************************************************************" | b x y sum max | x := Dictionary new. "allocate collection" x add: #a->4; add: #b->3; add: #c->1; add: #d->2; yourself. "add element to collection" x at: #e put: 3. "set element at index" b := x isEmpty. "test if empty" y := x size. "number of elements" y := x at: #a ifAbsent: []. "retrieve element at index" y := x keyAtValue: 3 ifAbsent: []. "retrieve key for given value with error block" y := x removeKey: #e ifAbsent: []. "remove element from collection" b := x includes: 3. "test if element is in values collection" b := x includesKey: #a. "test if element is in keys collection" y := x occurrencesOf: 3. "number of times object in collection" y := x keys. "set of keys" y := x values. "bag of values" x do: [:a | Transcript show: a printString; cr]. "iterate over the values collection" x keysDo: [:a | Transcript show: a printString; cr]. "iterate over the keys collection" x associationsDo: [:a | Transcript show: a printString; cr]. "iterate over the associations" x keysAndValuesDo: [:aKey :aValue | Transcript "iterate over keys and values" show: aKey printString; space; show: aValue printString; cr]. b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" Smalltalk at: #CMRGlobal put: ''CMR entry''. "put global in Smalltalk Dictionary" x := Smalltalk at: #CMRGlobal. "read global from Smalltalk Dictionary" Transcript show: (CMRGlobal printString). "entries are directly accessible by name" Smalltalk keys do: [ :k | "print out all classes" ((Smalltalk at: k) isKindOf: Class) ifFalse: [Transcript show: k printString; cr]]. Smalltalk at: #CMRDictionary put: (Dictionary new). "set up user defined dictionary" CMRDictionary at: #MyVar1 put: ''hello1''. "put entry in dictionary" CMRDictionary add: #MyVar2->''hello2''. "add entry to dictionary use key->value combo" CMRDictionary size. "dictionary size" CMRDictionary keys do: [ :k | "print out keys in dictionary" Transcript show: k printString; cr]. CMRDictionary values do: [ :k | "print out values in dictionary" Transcript show: k printString; cr]. CMRDictionary keysAndValuesDo: [:aKey :aValue | "print out keys and values" Transcript show: aKey printString; space; show: aValue printString; cr]. CMRDictionary associationsDo: [:aKeyValue | "another iterator for printing key values" Transcript show: aKeyValue printString; cr]. Smalltalk removeKey: #CMRGlobal ifAbsent: []. "remove entry from Smalltalk dictionary" Smalltalk removeKey: #CMRDictionary ifAbsent: []. "remove user dictionary from Smalltalk dictionary" '! ----- Method: TerseGuideHelp class>>dynamic (in category 'pages') ----- dynamic ^HelpTopic title: 'Dynamic Message Calling/Compiling' contents: '"************************************************************************ * Dynamic Message Calling/Compiling: * ************************************************************************" | receiver message result argument keyword1 keyword2 argument1 argument2 | "unary message" receiver := 5. message := ''factorial'' asSymbol. result := receiver perform: message. result := Compiler evaluate: ((receiver storeString), '' '', message). result := (Message new setSelector: message arguments: #()) sentTo: receiver. "binary message" receiver := 1. message := ''+'' asSymbol. argument := 2. result := receiver perform: message withArguments: (Array with: argument). result := Compiler evaluate: ((receiver storeString), '' '', message, '' '', (argument storeString)). result := (Message new setSelector: message arguments: (Array with: argument)) sentTo: receiver. "keyword messages" receiver := 12. keyword1 := ''between:'' asSymbol. keyword2 := ''and:'' asSymbol. argument1 := 10. argument2 := 20. result := receiver perform: (keyword1, keyword2) asSymbol withArguments: (Array with: argument1 with: argument2). result := Compiler evaluate: ((receiver storeString), '' '', keyword1, (argument1 storeString) , '' '', keyword2, (argument2 storeString)). result := (Message new setSelector: (keyword1, keyword2) asSymbol arguments: (Array with: argument1 with: argument2)) sentTo: receiver. '! ----- Method: TerseGuideHelp class>>fileStream (in category 'pages') ----- fileStream ^HelpTopic title: 'File Stream' contents: '"************************************************************************ * FileStream: * ************************************************************************" | b x ios | ios := FileStream newFileNamed: ''ios.txt''. ios nextPut: $H; cr. ios nextPutAll: ''Hello File''; cr. ''Hello File'' printOn: ios. ''Hello File'' storeOn: ios. ios close. ios := FileStream oldFileNamed: ''ios.txt''. [(x := ios nextLine) notNil] whileTrue: [Transcript show: x; cr]. ios position: 3. x := ios position. x := ios next. x := ios peek. b := ios atEnd. ios close. '! ----- Method: TerseGuideHelp class>>internalStream (in category 'pages') ----- internalStream ^HelpTopic title: 'Internal Stream' contents: '"************************************************************************ * Internal Stream: * ************************************************************************" | b x ios | ios := ReadStream on: ''Hello read stream''. ios := ReadStream on: ''Hello read stream'' from: 1 to: 5. [(x := ios nextLine) notNil] whileTrue: [Transcript show: x; cr]. ios position: 3. ios position. x := ios next. x := ios peek. x := ios contents. b := ios atEnd. ios := ReadWriteStream on: ''Hello read stream''. ios := ReadWriteStream on: ''Hello read stream'' from: 1 to: 5. ios := ReadWriteStream with: ''Hello read stream''. ios := ReadWriteStream with: ''Hello read stream'' from: 1 to: 10. ios position: 0. [(x := ios nextLine) notNil] whileTrue: [Transcript show: x; cr]. ios position: 6. ios position. ios nextPutAll: ''Chris''. x := ios next. x := ios peek. x := ios contents. b := ios atEnd. '! ----- Method: TerseGuideHelp class>>interval (in category 'pages') ----- interval ^HelpTopic title: 'Interval' contents: '"************************************************************************ * Interval: * ************************************************************************" | b x y sum max | x := Interval from: 5 to: 10. "create interval object" x := 5 to: 10. x := Interval from: 5 to: 10 by: 2. "create interval object with specified increment" x := 5 to: 10 by: 2. b := x isEmpty. "test if empty" y := x size. "number of elements" x includes: 9. "test if element is in collection" x do: [:k | Transcript show: k printString; cr]. "iterate over interval" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 7]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" y := x findFirst: [:a | a > 6]. "find position of first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := 0. 1 to: (x size) do: [:a | sum := sum + (x at: a)]. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>introduction (in category 'pages') ----- introduction ^HelpTopic title: 'General' contents: '"************************************************************************ * Allowable characters: * * - a-z * * - A-Z * * - 0-9 * * - .+/\*~<>@%|&? * * - blank, tab, cr, ff, lf * * * * Variables: * * - variables must be declared before use * * - shared vars must begin with uppercase * * - local vars must begin with lowercase * * - reserved names: nil, true, false, self, super, and Smalltalk * * * * Variable scope: * * - Global: defined in Dictionary Smalltalk and accessible by all * * objects in system * * - Special: (reserved) Smalltalk, super, self, true, false, & nil * * - Method Temporary: local to a method * * - Block Temporary: local to a block * * - Pool: variables in a Dictionary object * * - Method Parameters: automatic local vars created as a result of * * message call with params * * - Block Parameters: automatic local vars created as a result of * * value: message call * * - Class: shared with all instances of one class & its subclasses * * - Class Instance: unique to each instance of a class * * - Instance Variables: unique to each instance * ************************************************************************" "Comments are enclosed in quotes" "Period (.) is the statement seperator" '! ----- Method: TerseGuideHelp class>>iterationStatement (in category 'pages') ----- iterationStatement ^HelpTopic title: 'Iteration Statement' contents: '"************************************************************************ * Iteration statements: * ************************************************************************" | x y | x := 4. y := 1. [x > 0] whileTrue: [x := x - 1. y := y * 2]. "while true loop" [x >= 4] whileFalse: [x := x + 1. y := y * 2]. "while false loop" x timesRepeat: [y := y * 2]. "times repear loop (i := 1 to x)" 1 to: x do: [:a | y := y * 2]. "for loop" 1 to: x by: 2 do: [:a | y := y / 2]. "for loop with specified increment" #(5 4 3) do: [:a | x := x + a]. "iterate over array elements" '! ----- Method: TerseGuideHelp class>>metaclass (in category 'pages') ----- metaclass ^HelpTopic title: 'Class / Metaclass' contents: '"************************************************************************ * class/meta-class: * ************************************************************************" | b x | x := String name. "class name" x := String category. "organization category" x := String comment. "class comment" x := String kindOfSubclass. "subclass type - subclass: variableSubclass, etc" x := String definition. "class definition" x := String instVarNames. "immediate instance variable names" x := String allInstVarNames. "accumulated instance variable names" x := String classVarNames. "immediate class variable names" x := String allClassVarNames. "accumulated class variable names" x := String sharedPools. "immediate dictionaries used as shared pools" x := String allSharedPools. "accumulated dictionaries used as shared pools" x := String selectors. "message selectors for class" x := String sourceCodeAt: #indexOf:. "source code for specified method" x := String allInstances. "collection of all instances of class" x := String superclass. "immediate superclass" x := String allSuperclasses. "accumulated superclasses" x := String withAllSuperclasses. "receiver class and accumulated superclasses" x := String subclasses. "immediate subclasses" x := String allSubclasses. "accumulated subclasses" x := String withAllSubclasses. "receiver class and accumulated subclasses" b := String instSize. "number of named instance variables" b := String isFixed. "true if no indexed instance variables" b := String isVariable. "true if has indexed instance variables" b := String isPointers. "true if index instance vars contain objects" b := String isBits. "true if index instance vars contain bytes/words" b := String isBytes. "true if index instance vars contain bytes" b := String isWords. "true if index instance vars contain words" Object withAllSubclasses size. "get total number of class entries" '! ----- Method: TerseGuideHelp class>>methodCall (in category 'pages') ----- methodCall ^HelpTopic title: 'Method Call' contents: '"************************************************************************ * Method calls: * * - unary methods are messages with no arguments * * - binary methods * * - keyword methods are messages with selectors including colons * * * * standard categories/protocols: * * - initialize-release (methods called for new instance) * * - accessing (get/set methods) * * - testing (boolean tests - is) * * - comparing (boolean tests with parameter * * - displaying (gui related methods) * * - printing (methods for printing) * * - updating (receive notification of changes) * * - private (methods private to class) * * - instance-creation (class methods for creating instance) * ************************************************************************" | x | x := 2 sqrt. "unary message" x := 2 raisedTo: 10. "keyword message" x := 194 * 9. "binary message" Transcript show: (194 * 9) printString; cr. "combination (chaining)" x := 2 perform: #sqrt. "indirect method invocation" Transcript "Cascading - send multiple messages to receiver" show: ''hello ''; show: ''world''; cr. x := 3 + 2; * 100. "result=300. Sends message to same receiver (3)" '! ----- Method: TerseGuideHelp class>>misc (in category 'pages') ----- misc ^HelpTopic title: 'Miscellaneous' contents: '"************************************************************************ * Misc. * ************************************************************************" | x | "Smalltalk condenseChanges." "compress the change file" x := FillInTheBlank request: ''Prompt Me''. "prompt user for input" x := UIManager default request: ''Prompt Me''. "prompt user for input using a flexible UI dispatcher" Utilities openCommandKeyHelp '! ----- Method: TerseGuideHelp class>>orderedCollection (in category 'pages') ----- orderedCollection ^HelpTopic title: 'Ordered Collection' contents: '"************************************************************************ * OrderedCollection: acts like an expandable array * ************************************************************************" | b x y sum max | x := OrderedCollection with: 4 with: 3 with: 2 with: 1. "create collection with up to 4 elements" x := OrderedCollection new. "allocate collection" x add: 3; add: 2; add: 1; add: 4; yourself. "add element to collection" y := x addFirst: 5. "add element at beginning of collection" y := x removeFirst. "remove first element in collection" y := x addLast: 6. "add element at end of collection" y := x removeLast. "remove last element in collection" y := x addAll: #(7 8 9). "add multiple elements to collection" y := x removeAll: #(7 8 9). "remove multiple elements from collection" x at: 2 put: 3. "set element at index" y := x remove: 5 ifAbsent: []. "remove element from collection" b := x isEmpty. "test if empty" y := x size. "number of elements" y := x at: 2. "retrieve element at index" y := x first. "retrieve first element in collection" y := x last. "retrieve last element in collection" b := x includes: 5. "test if element is in collection" y := x copyFrom: 2 to: 3. "subcollection" y := x indexOf: 3 ifAbsent: [0]. "first position of element within collection" y := x occurrencesOf: 3. "number of times object in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the collection" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" y := x findFirst: [:a | a < 2]. "find position of first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := 0. 1 to: (x size) do: [:a | sum := sum + (x at: a)]. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x shuffled. "randomly shuffle collection" y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>pages (in category 'accessing') ----- pages ^ #( introduction transcript assignment constants boolean arithmetic bitwise conversion block methodCall conditionalStatement iterationStatement character symbol string array orderedCollection sortedCollection bag set interval association dictionary internalStream fileStream date time point rectangle pen dynamic metaclass debugging misc )! ----- Method: TerseGuideHelp class>>pen (in category 'pages') ----- pen ^HelpTopic title: 'Pen' contents: '"************************************************************************ * Pen: * ************************************************************************" | myPen | Display restoreAfter: [ Display fillWhite. myPen := Pen new. "get graphic pen" myPen squareNib: 1. myPen color: (Color blue). "set pen color" myPen home. "position pen at center of display" myPen up. "makes nib unable to draw" myPen down. "enable the nib to draw" myPen north. "points direction towards top" myPen turn: -180. "add specified degrees to direction" myPen direction. "get current angle of pen" myPen go: 50. "move pen specified number of pixels" myPen location. "get the pen position" myPen goto: 200@200. "move to specified point" myPen place: 250@250. "move to specified point without drawing" myPen print: ''Hello World'' withFont: (TextStyle default fontAt: 1). Display extent. "get display width@height" Display width. "get display width" Display height. "get display height" ]. '! ----- Method: TerseGuideHelp class>>point (in category 'pages') ----- point ^HelpTopic title: 'Point' contents: '"************************************************************************ * Point: * ************************************************************************" | x y | x := 200@100. "obtain a new point" y := x x. "x coordinate" y := x y. "y coordinate" x := 200@100 negated. "negates x and y" x := (-200@ -100) abs. "absolute value of x and y" x := (200.5@100.5) rounded. "round x and y" x := (200.5@100.5) truncated. "truncate x and y" x := 200@100 + 100. "add scale to both x and y" x := 200@100 - 100. "subtract scale from both x and y" x := 200@100 * 2. "multiply x and y by scale" x := 200@100 / 2. "divide x and y by scale" x := 200@100 // 2. "divide x and y by scale" x := 200@100 \\ 3. "remainder of x and y by scale" x := 200@100 + (50@25). "add points" x := 200@100 - (50@25). "subtract points" x := 200@100 * (3@4). "multiply points" x := 200@100 // (3@4). "divide points" x := 200@100 max: 50@200. "max x and y" x := 200@100 min: 50@200. "min x and y" x := 20@5 dotProduct: 10@2. "sum of product (x1*x2 + y1*y2)" '! ----- Method: TerseGuideHelp class>>rectangle (in category 'pages') ----- rectangle ^HelpTopic title: 'Rectangle' contents: '"************************************************************************ * Rectangle: * ************************************************************************" Rectangle fromUser. Rectangle origin: 0@0 corner: 100@100 "Origin and corners are absolute points" Rectangle origin: 80@40 extent: 50@50 "Extent is added to origin" Rectangle center: 40@50 extent: 30@20 "Center is half of extent" Rectangle left: 1 right: 20 top: 1 bottom: 10 | col | col := OrderedCollection new. col add: (Rectangle center: 40@50 extent: 30@20). col add: (Rectangle left: 1 right: 20 top: 1 bottom: 10). Rectangle merging: col '! ----- Method: TerseGuideHelp class>>set (in category 'pages') ----- set ^HelpTopic title: 'Set' contents: '"************************************************************************ * Set: like Bag except duplicates not allowed * * IdentitySet: uses identity test (== rather than =) * ************************************************************************" | b x y sum max | x := Set with: 4 with: 3 with: 2 with: 1. "create collection with up to 4 elements" x := Set new. "allocate collection" x add: 4; add: 3; add: 1; add: 2; yourself. "add element to collection" y := x addAll: #(7 8 9). "add multiple elements to collection" y := x removeAll: #(7 8 9). "remove multiple elements from collection" y := x remove: 4 ifAbsent: []. "remove element from collection" b := x isEmpty. "test if empty" y := x size. "number of elements" x includes: 4. "test if element is in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the collection" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>sortedCollection (in category 'pages') ----- sortedCollection ^HelpTopic title: 'Sorted Collection' contents: '"************************************************************************ * SortedCollection: like OrderedCollection except order of elements * * determined by sorting criteria * ************************************************************************" | b x y sum max | x := SortedCollection with: 4 with: 3 with: 2 with: 1. "create collection with up to 4 elements" x := SortedCollection new. "allocate collection" x := SortedCollection sortBlock: [:a :c | a > c]. "set sort criteria" x add: 3; add: 2; add: 1; add: 4; yourself. "add element to collection" "y := x addFirst: 5." "add element at beginning of collection" y := x removeFirst. "remove first element in collection" y := x addLast: 6. "add element at end of collection" y := x removeLast. "remove last element in collection" y := x addAll: #(7 8 9). "add multiple elements to collection" y := x removeAll: #(7 8 9). "remove multiple elements from collection" y := x remove: 5 ifAbsent: []. "remove element from collection" b := x isEmpty. "test if empty" y := x size. "number of elements" y := x at: 2. "retrieve element at index" y := x first. "retrieve first element in collection" y := x last. "retrieve last element in collection" b := x includes: 4. "test if element is in collection" y := x copyFrom: 2 to: 3. "subcollection" y := x indexOf: 3 ifAbsent: [0]. "first position of element within collection" y := x occurrencesOf: 3. "number of times object in collection" x do: [:a | Transcript show: a printString; cr]. "iterate over the collection" b := x allSatisfy: [:a | (a >= 1) & (a <= 4)]. "test if all elements meet condition" y := x select: [:a | a > 2]. "return collection of elements that pass test" y := x reject: [:a | a < 2]. "return collection of elements that fail test" y := x collect: [:a | a + a]. "transform each element for new collection" y := x detect: [:a | a > 3] ifNone: []. "return first element that passes test" y := x findFirst: [:a | a < 3]. "find position of first element that passes test" sum := 0. x do: [:a | sum := sum + a]. sum. "sum elements" sum := 0. 1 to: (x size) do: [:a | sum := sum + (x at: a)]. "sum elements" sum := x inject: 0 into: [:a :c | a + c]. "sum elements" max := x inject: 0 into: [:a :c | (a > c) "find max element in collection" ifTrue: [a] ifFalse: [c]]. y := x asArray. "convert to array" y := x asOrderedCollection. "convert to ordered collection" y := x asSortedCollection. "convert to sorted collection" y := x asBag. "convert to bag collection" y := x asSet. "convert to set collection" '! ----- Method: TerseGuideHelp class>>string (in category 'pages') ----- string ^HelpTopic title: 'String' contents: '"************************************************************************ * String: * ************************************************************************" | b x y | x := ''This is a string''. "string assignment" x := ''String'', ''Concatenation''. "string concatenation" b := x isEmpty. "test if string is empty" y := x size. "string size" y := x at: 2. "char at location" y := x copyFrom: 2 to: 4. "substring" y := x indexOf: $a ifAbsent: [0]. "first position of character within string" x := String new: 4. "allocate string object" x "set string elements" at: 1 put: $a; at: 2 put: $b; at: 3 put: $c; at: 4 put: $e. x := String with: $a with: $b with: $c with: $d. "set up to 4 elements at a time" x do: [:a | Transcript show: a printString; cr]. "iterate over the string" b := x allSatisfy: [:a | (a >= $a) & (a <= $z)]. "test if all elements meet condition" y := x select: [:a | a > $a]. "return all elements that meet condition" y := x asSymbol. "convert string to symbol" y := x asArray. "convert string to array" x := ''ABCD'' asByteArray. "convert string to byte array" y := x asOrderedCollection. "convert string to ordered collection" y := x asSortedCollection. "convert string to sorted collection" y := x asBag. "convert string to bag collection" y := x asSet. "convert string to set collection" y := x shuffled. "randomly shuffle string" '! ----- Method: TerseGuideHelp class>>symbol (in category 'pages') ----- symbol ^HelpTopic title: 'Symbol' contents: '"************************************************************************ * Symbol: * ************************************************************************" | b x y | x := #Hello. "symbol assignment" y := ''String'', ''Concatenation''. "symbol concatenation (result is string)" b := x isEmpty. "test if symbol is empty" y := x size. "string size" y := x at: 2. "char at location" y := x copyFrom: 2 to: 4. "substring" y := x indexOf: $e ifAbsent: [0]. "first position of character within string" x do: [:a | Transcript show: a printString; cr]. "iterate over the string" b := x allSatisfy: [:a | (a >= $a) & (a <= $z)]. "test if all elements meet condition" y := x select: [:a | a > $a]. "return all elements that meet condition" y := x asString. "convert symbol to string" y := x asText. "convert symbol to text" y := x asArray. "convert symbol to array" y := x asOrderedCollection. "convert symbol to ordered collection" y := x asSortedCollection. "convert symbol to sorted collection" y := x asBag. "convert symbol to bag collection" y := x asSet. "convert symbol to set collection" '! ----- Method: TerseGuideHelp class>>time (in category 'pages') ----- time ^HelpTopic title: 'Time' contents: '"************************************************************************ * Time: * ************************************************************************" | x y b | x := Time now. "create time from current time" x := Time dateAndTimeNow. "create time from current time/date" x := Time readFromString: ''3:47:26 pm''. "create time from formatted string" x := Time fromSeconds: (60 * 60 * 4). "create time from elapsed time from midnight" y := Time millisecondClockValue. "milliseconds since midnight" y := Time totalSeconds. "total seconds since 1/1/1901" y := x seconds. "seconds past minute (0-59)" y := x minutes. "minutes past hour (0-59)" y := x hours. "hours past midnight (0-23)" y := x addTime: (Time now). "add time to time object" y := x subtractTime: (Time now). "subtract time to time object" y := x asSeconds. "convert time to seconds" x := Time millisecondsToRun: [ "timing facility" 1 to: 1000 do: [:index | y := 3.14 * index]]. "b := (x <= Time now)." "comparison" '! ----- Method: TerseGuideHelp class>>transcript (in category 'pages') ----- transcript ^HelpTopic title: 'Transcript' contents: '"************************************************************************ * Transcript: * ************************************************************************" Transcript clear. "clear to transcript window" Transcript show: ''Hello World''. "output string in transcript window" Transcript nextPutAll: ''Hello World''. "output string in transcript window" Transcript nextPut: $A. "output character in transcript window" Transcript space. "output space character in transcript window" Transcript tab. "output tab character in transcript window" Transcript cr. "carriage return / linefeed" ''Hello'' printOn: Transcript. "append print string into the window" ''Hello'' storeOn: Transcript. "append store string into the window" Transcript endEntry. "flush the output buffer" '! From commits at source.squeak.org Fri Jun 5 20:19:56 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:19:58 2015 Subject: [squeak-dev] Squeak 4.6: ToolBuilder-Kernel-mt.89.mcz Message-ID: Chris Muller uploaded a new version of ToolBuilder-Kernel to project Squeak 4.6: http://source.squeak.org/squeak46/ToolBuilder-Kernel-mt.89.mcz ==================== Summary ==================== Name: ToolBuilder-Kernel-mt.89 Author: mt Time: 12 May 2015, 9:02:56.628 pm UUID: 5175a13e-cae3-8f48-bd99-8a7d0d012866 Ancestors: ToolBuilder-Kernel-mt.88 Allow input fields to provide soft-line-wrap. ==================== Snapshot ==================== SystemOrganization addCategory: #'ToolBuilder-Kernel'! Notification subclass: #ProgressInitiationException instanceVariableNames: 'workBlock maxVal minVal aPoint progressTitle' classVariableNames: 'PreferredProgressBarPosition' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !ProgressInitiationException commentStamp: '' prior: 0! I provide a way to alter the behavior of the old-style progress notifier in String. See examples in: ProgressInitiationException testWithout. ProgressInitiationException testWith. ! ----- Method: ProgressInitiationException class>>display:at:from:to:during: (in category 'signalling') ----- display: aString at: aPoint from: minVal to: maxVal during: workBlock ^ self new display: aString at: (aPoint ifNil: [ self preferredProgressBarPoint ]) from: minVal to: maxVal during: workBlock! ----- Method: ProgressInitiationException class>>display:from:to:during: (in category 'signalling') ----- display: aString from: minVal to: maxVal during: workBlock ^ self display: aString at: nil from: minVal to: maxVal during: workBlock! ----- Method: ProgressInitiationException class>>preferredProgressBarPoint (in category 'accessing') ----- preferredProgressBarPoint ^ self preferredProgressBarPosition = #cursorPoint ifTrue: [ Sensor cursorPoint ] ifFalse: [ UIManager default screenBounds perform: self preferredProgressBarPosition ]! ----- Method: ProgressInitiationException class>>preferredProgressBarPosition (in category 'accessing') ----- preferredProgressBarPosition ^ PreferredProgressBarPosition ifNil: [ #center ]! ----- Method: ProgressInitiationException class>>preferredProgressBarPosition: (in category 'accessing') ----- preferredProgressBarPosition: aSymbol "Specify any of: #center, #topCenter, #bottomCenter, #leftCenter, #rightCenter, #topLeft, #topRight, #bottomLeft or #bottomRight or #cursorPoint." ^ PreferredProgressBarPosition! ----- Method: ProgressInitiationException class>>testInnermost (in category 'examples and tests') ----- testInnermost "test the progress code WITHOUT special handling" ^'Now here''s some Real Progress' displayProgressFrom: 0 to: 10 during: [ :bar | 1 to: 10 do: [ :x | bar value: x. (Delay forMilliseconds: 500) wait. x = 5 ifTrue: [1/0]. "just to make life interesting" ]. 'done' ]. ! ----- Method: ProgressInitiationException class>>testWith (in category 'examples and tests') ----- testWith "test progress code WITH special handling of progress notifications" ^[ self testWithAdditionalInfo ] on: ProgressInitiationException do: [ :ex | ex sendNotificationsTo: [ :min :max :curr | Transcript show: min printString,' ',max printString,' ',curr printString; cr ]. ]. ! ----- Method: ProgressInitiationException class>>testWithAdditionalInfo (in category 'examples and tests') ----- testWithAdditionalInfo ^{'starting'. self testWithout. 'really!!'}! ----- Method: ProgressInitiationException class>>testWithout (in category 'examples and tests') ----- testWithout "test the progress code WITHOUT special handling" ^[self testInnermost] on: ZeroDivide do: [ :ex | ex resume] ! ----- Method: ProgressInitiationException>>defaultAction (in category 'handling') ----- defaultAction self resume! ----- Method: ProgressInitiationException>>defaultResumeValue (in category 'handling') ----- defaultResumeValue ^ UIManager default displayProgress: progressTitle at: aPoint from: minVal to: maxVal during: workBlock! ----- Method: ProgressInitiationException>>display:at:from:to:during: (in category 'initialize-release') ----- display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock progressTitle := argString. aPoint := argPoint. minVal := argMinVal. maxVal := argMaxVal. workBlock := argWorkBlock. ^self signal! ----- Method: ProgressInitiationException>>sendNotificationsTo: (in category 'initialize-release') ----- sendNotificationsTo: aNewBlock self resume: ( workBlock value: [ :barVal | aNewBlock value: minVal value: maxVal value: barVal ] ) ! ----- Method: String>>displayProgressAt:from:to:during: (in category '*toolbuilder-kernel') ----- 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! ----- Method: String>>displayProgressFrom:to:during: (in category '*toolbuilder-kernel') ----- displayProgressFrom: 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' displayProgressFrom: 0 to: 10 during: [:bar | 1 to: 10 do: [:x | bar value: x. (Delay forMilliseconds: 500) wait]]." ^ self displayProgressAt: nil from: minVal to: maxVal during: workBlock! ----- Method: Object>>confirm: (in category '*ToolBuilder-Kernel-error handling') ----- 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." "nil confirm: 'Are you hungry?'" ^ UIManager default confirm: queryString! ----- Method: Object>>confirm:orCancel: (in category '*ToolBuilder-Kernel-error handling') ----- confirm: aString 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." ^ UIManager default confirm: aString orCancel: cancelBlock! ----- Method: Object>>inform: (in category '*ToolBuilder-Kernel-user interface') ----- inform: aString "Display a message for the user to read and then dismiss. 6/9/96 sw" aString isEmptyOrNil ifFalse: [UIManager default inform: aString]! Object subclass: #ToolBuilder instanceVariableNames: 'parent' classVariableNames: 'OpenToolsAttachedToMouseCursor' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !ToolBuilder commentStamp: '' prior: 0! I am a tool builder, that is an object which knows how to create concrete widgets from abstract specifications. Those specifications are used by tools which want to be able to function in diverse user interface paradigms, such as MVC, Morphic, Tweak, wxWidgets etc. The following five specs must be supported by all implementations: * PluggableButton * PluggableList * PluggableText * PluggablePanel * PluggableWindow The following specs are optional: * PluggableTree: If not supported, the tool builder must answer nil when asked for a pluggableTreeSpec. Substitution will require client support so clients must be aware that some tool builders may not support trees (MVC for example, or Seaside). See examples in FileListPlus or TestRunnerPlus. * PluggableMultiSelectionList: If multi-selection lists are not supported, tool builder will silently support regular single selection lists. * PluggableInputField: Intended as a HINT for the builder that this widget will be used as a single line input field. Unless explicitly supported it will be automatically substituted by PluggableText. * PluggableActionButton: Intended as a HINT for the builder that this widget will be used as push (action) button. Unless explicitly supported it will be automatically substituted by PluggableButton. * PluggableRadioButton: Intended as a HINT for the builder that this widget will be used as radio button. Unless explicitly supported it will be automatically substituted by PluggableButton. * PluggableCheckBox: Intended as a HINT for the builder that this widget will be used as check box. Unless explicitly supported it will be automatically substituted by PluggableButton. ! ----- Method: ToolBuilder class>>build: (in category 'instance creation') ----- build: aClass ^self default build: aClass! ----- Method: ToolBuilder class>>default (in category 'accessing') ----- default "Answer the default tool builder" ^ Project current uiManager toolBuilder ! ----- Method: ToolBuilder class>>findDefault (in category 'accessing') ----- findDefault "Answer a default tool builder" | builderClass | "Note: The way the following is phrased ensures that you can always make 'more specific' builders merely by subclassing a tool builder and implementing a more specific way of reacting to #isActiveBuilder. For example, a BobsUIToolBuilder can subclass MorphicToolBuilder and (if enabled, say Preferences useBobsUITools) will be considered before the parent (generic MorphicToolBuilder)." builderClass := self allSubclasses detect:[:any| any isActiveBuilder and:[ any subclasses noneSatisfy:[:sub| sub isActiveBuilder]]] ifNone:[nil]. builderClass ifNotNil: [^builderClass ]. ^self error: 'ToolBuilder not found'! ----- Method: ToolBuilder class>>isActiveBuilder (in category 'accessing') ----- isActiveBuilder "Answer whether I am the currently active builder" ^false! ----- Method: ToolBuilder class>>open: (in category 'instance creation') ----- open: aClass ^self default open: aClass! ----- Method: ToolBuilder class>>open:label: (in category 'instance creation') ----- open: aClass label: aString ^self default open: aClass label: aString! ----- Method: ToolBuilder class>>openToolsAttachedToMouseCursor (in category 'preferences') ----- openToolsAttachedToMouseCursor ^ OpenToolsAttachedToMouseCursor ifNil: [false]! ----- Method: ToolBuilder class>>openToolsAttachedToMouseCursor: (in category 'preferences') ----- openToolsAttachedToMouseCursor: aBoolean OpenToolsAttachedToMouseCursor := aBoolean.! ----- Method: ToolBuilder>>build: (in category 'building') ----- build: anObject "Build the given object using this tool builder" ^anObject buildWith: self! ----- Method: ToolBuilder>>buildAll:in: (in category 'building') ----- buildAll: aList in: newParent "Build the given set of widgets in the new parent" | prior | aList ifNil:[^self]. prior := parent. parent := newParent. aList do:[:each| each buildWith: self]. parent := prior. ! ----- Method: ToolBuilder>>buildPluggableActionButton: (in category 'widgets optional') ----- buildPluggableActionButton: spec ^self buildPluggableButton: spec! ----- Method: ToolBuilder>>buildPluggableAlternateMultiSelectionList: (in category 'widgets optional') ----- buildPluggableAlternateMultiSelectionList: aSpec ^ self buildPluggableList: aSpec! ----- Method: ToolBuilder>>buildPluggableButton: (in category 'widgets required') ----- buildPluggableButton: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableCheckBox: (in category 'widgets optional') ----- buildPluggableCheckBox: spec ^self buildPluggableButton: spec! ----- Method: ToolBuilder>>buildPluggableCodePane: (in category 'widgets optional') ----- buildPluggableCodePane: aSpec ^self buildPluggableText: aSpec! ----- Method: ToolBuilder>>buildPluggableDropDownList: (in category 'widgets optional') ----- buildPluggableDropDownList: spec ^self buildPluggableList: spec! ----- Method: ToolBuilder>>buildPluggableInputField: (in category 'widgets optional') ----- buildPluggableInputField: aSpec ^self buildPluggableText: aSpec! ----- Method: ToolBuilder>>buildPluggableList: (in category 'widgets required') ----- buildPluggableList: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableMenu: (in category 'widgets required') ----- buildPluggableMenu: menuSpec self subclassResponsibility.! ----- Method: ToolBuilder>>buildPluggableMenuItem: (in category 'widgets required') ----- buildPluggableMenuItem: menuSpec self subclassResponsibility.! ----- Method: ToolBuilder>>buildPluggableMultiSelectionList: (in category 'widgets optional') ----- buildPluggableMultiSelectionList: aSpec ^self buildPluggableList: aSpec! ----- Method: ToolBuilder>>buildPluggablePanel: (in category 'widgets required') ----- buildPluggablePanel: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableRadioButton: (in category 'widgets optional') ----- buildPluggableRadioButton: spec ^self buildPluggableButton: spec! ----- Method: ToolBuilder>>buildPluggableScrollPane: (in category 'widgets optional') ----- buildPluggableScrollPane: spec ^ spec children ifNotNil: [self buildPluggablePanel: spec] ifNil: [spec morph ifNil: [spec morphClass new]]! ----- Method: ToolBuilder>>buildPluggableSpacer: (in category 'widgets required') ----- buildPluggableSpacer: aSpec ^ self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableText: (in category 'widgets required') ----- buildPluggableText: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableTree: (in category 'widgets required') ----- buildPluggableTree: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>buildPluggableWindow: (in category 'widgets required') ----- buildPluggableWindow: aSpec ^self subclassResponsibility! ----- Method: ToolBuilder>>close: (in category 'opening') ----- close: aWidget "Close a previously opened widget" ^self subclassResponsibility! ----- Method: ToolBuilder>>initialize (in category 'initialize') ----- initialize ! ----- Method: ToolBuilder>>open: (in category 'opening') ----- open: anObject "Build and open the object. Answer the widget opened." ^self subclassResponsibility! ----- Method: ToolBuilder>>open:label: (in category 'opening') ----- open: anObject label: aString "Build an open the object, labeling it appropriately. Answer the widget opened." ^self subclassResponsibility! ----- Method: ToolBuilder>>openDebugger: (in category 'opening') ----- openDebugger: aSpec "Build and open a debugger from the given spec. Answer the widget opened. Subclasses can override this method if opening a debugger has specific requirements different from opening other widgets." self open: aSpec ! ----- Method: ToolBuilder>>openDebugger:label: (in category 'opening') ----- openDebugger: aSpec label: aString "Build and open a debugger from the given spec, labeling it appropriately. Answer the widget opened. Subclasses can override this method if opening a debugger has specific requirements different from opening other widgets." ^self open: aSpec label: aString ! ----- Method: ToolBuilder>>openDebugger:label:closing: (in category 'opening') ----- openDebugger: aSpec label: aString closing: topView "Build and open a debugger from the given spec, labeling it appropriately. Answer the widget opened. Subclasses can override this method if opening a debugger has specific requirements different from opening other widgets." self close: topView. self open: aSpec label: aString ! ----- Method: ToolBuilder>>parent (in category 'accessing') ----- parent ^parent! ----- Method: ToolBuilder>>parent: (in category 'accessing') ----- parent: aWidget parent := aWidget! ----- Method: ToolBuilder>>pluggableActionButtonSpec (in category 'defaults') ----- pluggableActionButtonSpec ^PluggableActionButtonSpec! ----- Method: ToolBuilder>>pluggableAlternateMultiSelectionListSpec (in category 'defaults') ----- pluggableAlternateMultiSelectionListSpec ^ PluggableAlternateMultiSelectionListSpec! ----- Method: ToolBuilder>>pluggableButtonSpec (in category 'defaults') ----- pluggableButtonSpec ^PluggableButtonSpec! ----- Method: ToolBuilder>>pluggableCheckBoxSpec (in category 'defaults') ----- pluggableCheckBoxSpec ^PluggableCheckBoxSpec! ----- Method: ToolBuilder>>pluggableCodePaneSpec (in category 'defaults') ----- pluggableCodePaneSpec ^PluggableCodePaneSpec! ----- Method: ToolBuilder>>pluggableDropDownListSpec (in category 'defaults') ----- pluggableDropDownListSpec ^PluggableDropDownListSpec! ----- Method: ToolBuilder>>pluggableInputFieldSpec (in category 'defaults') ----- pluggableInputFieldSpec ^PluggableInputFieldSpec! ----- Method: ToolBuilder>>pluggableListSpec (in category 'defaults') ----- pluggableListSpec ^PluggableListSpec! ----- Method: ToolBuilder>>pluggableMenuSpec (in category 'defaults') ----- pluggableMenuSpec ^ PluggableMenuSpec! ----- Method: ToolBuilder>>pluggableMultiSelectionListSpec (in category 'defaults') ----- pluggableMultiSelectionListSpec ^PluggableMultiSelectionListSpec! ----- Method: ToolBuilder>>pluggablePanelSpec (in category 'defaults') ----- pluggablePanelSpec ^PluggablePanelSpec! ----- Method: ToolBuilder>>pluggableRadioButtonSpec (in category 'defaults') ----- pluggableRadioButtonSpec ^PluggableRadioButtonSpec! ----- Method: ToolBuilder>>pluggableScrollPaneSpec (in category 'defaults') ----- pluggableScrollPaneSpec ^ PluggableScrollPaneSpec! ----- Method: ToolBuilder>>pluggableSpacerSpec (in category 'defaults') ----- pluggableSpacerSpec ^ PluggableSpacerSpec! ----- Method: ToolBuilder>>pluggableTextSpec (in category 'defaults') ----- pluggableTextSpec ^PluggableTextSpec! ----- Method: ToolBuilder>>pluggableTreeSpec (in category 'defaults') ----- pluggableTreeSpec ^PluggableTreeSpec! ----- Method: ToolBuilder>>pluggableWindowSpec (in category 'defaults') ----- pluggableWindowSpec ^PluggableWindowSpec! ----- Method: ToolBuilder>>runModal: (in category 'opening') ----- runModal: aWidget "Run the (previously opened) widget modally, e.g., do not return control to the sender before the user has responded." ^self subclassResponsibility! ----- Method: ToolBuilder>>widgetAt: (in category 'accessing') ----- widgetAt: widgetID "Answer the widget with the given ID" ^self widgetAt: widgetID ifAbsent:[nil]! ----- Method: ToolBuilder>>widgetAt:ifAbsent: (in category 'accessing') ----- widgetAt: widgetID ifAbsent: aBlock "Answer the widget with the given ID" ^aBlock value! Object subclass: #ToolBuilderSpec instanceVariableNames: 'name help' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !ToolBuilderSpec commentStamp: 'ar 2/11/2005 14:59' prior: 0! I am an abstract widget specification. I can be rendered using many different UI frameworks.! ToolBuilderSpec subclass: #PluggableMenuItemSpec instanceVariableNames: 'label action checked enabled separator subMenu checkable' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableMenuItemSpec>>action (in category 'accessing') ----- action "Answer the action associated with the receiver" ^action! ----- Method: PluggableMenuItemSpec>>action: (in category 'accessing') ----- action: aMessageSend "Answer the action associated with the receiver" action := aMessageSend! ----- Method: PluggableMenuItemSpec>>analyzeLabel (in category 'initialize') ----- analyzeLabel "For Morphic compatiblity. Some labels include markup such as , etc. Analyze the label for these annotations and take appropriate action." | marker | marker := label copyFrom: 1 to: (label indexOf: $>). (marker = '' or:[marker = '']) ifTrue:[ checkable := true. checked := true. label := label copyFrom: marker size+1 to: label size. ]. (marker = '' or:[marker = '']) ifTrue:[ checkable := true. checked := false. label := label copyFrom: marker size+1 to: label size. ]. ! ----- Method: PluggableMenuItemSpec>>beCheckable (in category 'accessing') ----- beCheckable checkable := true.! ----- Method: PluggableMenuItemSpec>>buildWith: (in category 'building') ----- buildWith: builder ^ builder buildPluggableMenuItem: self! ----- Method: PluggableMenuItemSpec>>checked (in category 'accessing') ----- checked "Answer whether the receiver is checked" ^checked ifNil:[false]! ----- Method: PluggableMenuItemSpec>>checked: (in category 'accessing') ----- checked: aBool "Indicate whether the receiver is checked" checked := aBool.! ----- Method: PluggableMenuItemSpec>>enabled (in category 'accessing') ----- enabled "Answer whether the receiver is enabled" ^enabled ifNil:[true]! ----- Method: PluggableMenuItemSpec>>enabled: (in category 'accessing') ----- enabled: aBool "Indicate whether the receiver is enabled" enabled := aBool! ----- Method: PluggableMenuItemSpec>>initialize (in category 'initialize') ----- initialize checkable := false.! ----- Method: PluggableMenuItemSpec>>isCheckable (in category 'accessing') ----- isCheckable ^ checkable! ----- Method: PluggableMenuItemSpec>>label (in category 'accessing') ----- label "Answer the receiver's label" ^label! ----- Method: PluggableMenuItemSpec>>label: (in category 'accessing') ----- label: aString "Set the receiver's label" label := aString! ----- Method: PluggableMenuItemSpec>>separator (in category 'accessing') ----- separator "Answer whether the receiver should be followed by a separator" ^separator ifNil:[false]! ----- Method: PluggableMenuItemSpec>>separator: (in category 'accessing') ----- separator: aBool "Indicate whether the receiver should be followed by a separator" separator := aBool.! ----- Method: PluggableMenuItemSpec>>subMenu (in category 'accessing') ----- subMenu "Answer the receiver's subMenu" ^subMenu! ----- Method: PluggableMenuItemSpec>>subMenu: (in category 'accessing') ----- subMenu: aMenuSpec "Answer the receiver's subMenu" subMenu := aMenuSpec! ToolBuilderSpec subclass: #PluggableMenuSpec instanceVariableNames: 'label model items' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableMenuSpec class>>withModel: (in category 'as yet unclassified') ----- withModel: aModel ^ self new model: aModel! ----- Method: PluggableMenuSpec>>add:action: (in category 'construction') ----- add: aString action: aMessageSend | item | item := self addMenuItem. item label: aString. item action: aMessageSend. ^item! ----- Method: PluggableMenuSpec>>add:target:selector:argumentList: (in category 'construction') ----- add: aString target: anObject selector: aSelector argumentList: anArray ^self add: aString action: (MessageSend receiver: anObject selector: aSelector arguments: anArray).! ----- Method: PluggableMenuSpec>>addList: (in category 'construction') ----- addList: aList "Add the given items to this menu, where each item is a pair ( ).. 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 addSeparator] ifFalse:[ | item | item := self add: tuple first target: model selector: tuple second argumentList: #(). tuple size > 2 ifTrue:[item help: tuple third]]]! ----- Method: PluggableMenuSpec>>addMenuItem (in category 'construction') ----- addMenuItem | item | item := self newMenuItem. self items add: item. ^item! ----- Method: PluggableMenuSpec>>addSeparator (in category 'construction') ----- addSeparator self items isEmpty ifTrue:[^nil]. self items last separator: true.! ----- Method: PluggableMenuSpec>>analyzeItemLabels (in category 'construction') ----- analyzeItemLabels "Analyze the item labels" items do:[:item| item analyzeLabel]. ! ----- Method: PluggableMenuSpec>>buildWith: (in category 'construction') ----- buildWith: builder self analyzeItemLabels. ^ builder buildPluggableMenu: self! ----- Method: PluggableMenuSpec>>items (in category 'accessing') ----- items ^ items ifNil: [items := OrderedCollection new]! ----- Method: PluggableMenuSpec>>label (in category 'accessing') ----- label ^label! ----- Method: PluggableMenuSpec>>label: (in category 'accessing') ----- label: aString label := aString.! ----- Method: PluggableMenuSpec>>model (in category 'accessing') ----- model ^ model! ----- Method: PluggableMenuSpec>>model: (in category 'accessing') ----- model: anObject model := anObject! ----- Method: PluggableMenuSpec>>newMenuItem (in category 'construction') ----- newMenuItem ^PluggableMenuItemSpec new! ToolBuilderSpec subclass: #PluggableWidgetSpec instanceVariableNames: 'model frame color minimumExtent margin padding horizontalResizing verticalResizing' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableWidgetSpec commentStamp: 'ar 2/9/2005 18:40' prior: 0! The abstract superclass for all widgets. Instance variables: model The object the various requests should be directed to. frame The associated layout frame for this object (if any). ! PluggableWidgetSpec subclass: #PluggableButtonSpec instanceVariableNames: 'action label state enabled style changeLabelWhen' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableButtonSpec commentStamp: 'ar 2/11/2005 21:57' prior: 0! A button, both for firing as well as used in radio-button style (e.g., carrying a selection). Instance variables: action The action to perform when the button is fired. label The selector for retrieving the button's label or label directly. state The selector for retrieving the button's selection state. enabled The selector for retrieving the button's enabled state. color The selector for retrieving the button color. help The balloon help for the button.! PluggableButtonSpec subclass: #PluggableActionButtonSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableActionButtonSpec commentStamp: 'dtl 9/19/2011 07:51' prior: 0! PluggableActionButtonSpec is intended as a HINT for the builder that this widget will be used as push (action) button. Unless explicitly supported it will be automatically substituted by PluggableButton.! ----- Method: PluggableActionButtonSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableActionButton: self! ----- Method: PluggableButtonSpec>>action (in category 'accessing') ----- action "Answer the action to be performed by the receiver" ^action! ----- Method: PluggableButtonSpec>>action: (in category 'accessing') ----- action: aSymbol "Indicate the action to be performed by the receiver" action := aSymbol! ----- Method: PluggableButtonSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableButton: self! ----- Method: PluggableButtonSpec>>changeLabelWhen (in category 'accessing') ----- changeLabelWhen "When handled in in an update: handler, treat this symbol as notification that the button label should be updated." ^changeLabelWhen! ----- Method: PluggableButtonSpec>>changeLabelWhen: (in category 'accessing') ----- changeLabelWhen: aSymbol "When the button handles aSymbol in its update: handler, treat it as notification that the button label should be updated." changeLabelWhen := aSymbol! ----- Method: PluggableButtonSpec>>enabled (in category 'accessing') ----- enabled "Answer the selector for retrieving the button's enablement" ^enabled ifNil:[true]! ----- Method: PluggableButtonSpec>>enabled: (in category 'accessing') ----- enabled: aSymbol "Indicate the selector for retrieving the button's enablement" enabled := aSymbol! ----- Method: PluggableButtonSpec>>label (in category 'accessing') ----- label "Answer the label (or the selector for retrieving the label)" ^label! ----- Method: PluggableButtonSpec>>label: (in category 'accessing') ----- label: aSymbol "Indicate the selector for retrieving the label" label := aSymbol.! ----- Method: PluggableButtonSpec>>state (in category 'accessing') ----- state "Answer the selector for retrieving the button's state" ^state! ----- Method: PluggableButtonSpec>>state: (in category 'accessing') ----- state: aSymbol "Indicate the selector for retrieving the button's state" state := aSymbol.! ----- Method: PluggableButtonSpec>>style (in category 'accessing') ----- style "Treat aSymbol as a hint to modify the button appearance." ^style ! ----- Method: PluggableButtonSpec>>style: (in category 'accessing') ----- style: aSymbol "Use aSymbol as a hint to modify the button appearance." style := aSymbol ! PluggableButtonSpec subclass: #PluggableCheckBoxSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableCheckBoxSpec commentStamp: 'ar 2/12/2005 23:13' prior: 0! PluggableCheckBox is intended as a HINT for the builder that this widget will be used as check box. Unless explicitly supported it will be automatically substituted by PluggableButton.! ----- Method: PluggableCheckBoxSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableCheckBox: self! PluggableButtonSpec subclass: #PluggableRadioButtonSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableRadioButtonSpec commentStamp: 'ar 2/12/2005 23:14' prior: 0! PluggableRadioButton is intended as a HINT for the builder that this widget will be used as radio button. Unless explicitly supported it will be automatically substituted by PluggableButton.! ----- Method: PluggableRadioButtonSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableRadioButton: self! PluggableWidgetSpec subclass: #PluggableCompositeSpec instanceVariableNames: 'children layout wantsResizeHandles spacing' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableCompositeSpec commentStamp: 'ar 2/11/2005 21:58' prior: 0! A composite user interface element. Instance variables: children Symbol to retrieve children or children directly layout The layout for this composite. ! ----- Method: PluggableCompositeSpec>>children (in category 'accessing') ----- children "Answer the selector to retrieve this panel's children" ^children! ----- Method: PluggableCompositeSpec>>children: (in category 'accessing') ----- children: aSymbol "Indicate the selector to retrieve this panel's children" children := aSymbol! ----- Method: PluggableCompositeSpec>>layout (in category 'accessing') ----- layout "Answer the symbol indicating the layout of the composite: #proportional (default): Use frames as appropriate. #horizontal: Arrange the elements horizontally #vertical: Arrange the elements vertically. " ^layout ifNil:[#proportional]! ----- Method: PluggableCompositeSpec>>layout: (in category 'accessing') ----- layout: aSymbol "Answer the symbol indicating the layout of the composite: #proportional (default): Use frames as appropriate. #horizontal: Arrange the elements horizontally #vertical: Arrange the elements vertically. " layout := aSymbol! ----- Method: PluggableCompositeSpec>>spacing (in category 'layout hints') ----- spacing "...between components of this widget." ^ spacing! ----- Method: PluggableCompositeSpec>>spacing: (in category 'layout hints') ----- spacing: numberOrPoint spacing := numberOrPoint.! ----- Method: PluggableCompositeSpec>>wantsResizeHandles (in category 'accessing') ----- wantsResizeHandles ^ wantsResizeHandles! ----- Method: PluggableCompositeSpec>>wantsResizeHandles: (in category 'accessing') ----- wantsResizeHandles: aBoolean wantsResizeHandles := aBoolean.! PluggableCompositeSpec subclass: #PluggablePanelSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggablePanelSpec commentStamp: 'ar 2/11/2005 15:01' prior: 0! A panel with a (possibly changing) set of child elements. Expects to see change/update notifications when the childrens change.! ----- Method: PluggablePanelSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggablePanel: self.! PluggableCompositeSpec subclass: #PluggableScrollPaneSpec instanceVariableNames: 'morph morphClass borderWidth vScrollBarPolicy hScrollBarPolicy' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableScrollPaneSpec>>borderWidth (in category 'accessing') ----- borderWidth ^ borderWidth ifNil: [1]! ----- Method: PluggableScrollPaneSpec>>borderWidth: (in category 'accessing') ----- borderWidth: anObject borderWidth := anObject! ----- Method: PluggableScrollPaneSpec>>buildWith: (in category 'building') ----- buildWith: builder ^ builder buildPluggableScrollPane: self! ----- Method: PluggableScrollPaneSpec>>hScrollBarPolicy (in category 'accessing') ----- hScrollBarPolicy ^ hScrollBarPolicy ifNil: [#always]! ----- Method: PluggableScrollPaneSpec>>hScrollBarPolicy: (in category 'accessing') ----- hScrollBarPolicy: anObject "#always, #never, #whenNeeded" hScrollBarPolicy := anObject! ----- Method: PluggableScrollPaneSpec>>morph (in category 'accessing') ----- morph ^ morph! ----- Method: PluggableScrollPaneSpec>>morph: (in category 'accessing') ----- morph: anObject morph := anObject! ----- Method: PluggableScrollPaneSpec>>morphClass (in category 'accessing') ----- morphClass ^ morphClass! ----- Method: PluggableScrollPaneSpec>>morphClass: (in category 'accessing') ----- morphClass: anObject morphClass := anObject! ----- Method: PluggableScrollPaneSpec>>vScrollBarPolicy (in category 'accessing') ----- vScrollBarPolicy ^ vScrollBarPolicy ifNil: [#always]! ----- Method: PluggableScrollPaneSpec>>vScrollBarPolicy: (in category 'accessing') ----- vScrollBarPolicy: anObject "#always, #never, #whenNeeded" vScrollBarPolicy := anObject! PluggableCompositeSpec subclass: #PluggableWindowSpec instanceVariableNames: 'label extent closeAction isDialog multiWindowStyle' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableWindowSpec commentStamp: '' prior: 0! A common window. Expects to see change/update notifications when the label should change. Instance variables: label The selector under which to retrieve the label or the label directly extent The (initial) extent of the window. closeAction The action to perform when the window is closed.! ----- Method: PluggableWindowSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableWindow: self.! ----- Method: PluggableWindowSpec>>closeAction (in category 'accessing') ----- closeAction "Answer the receiver's closeAction" ^closeAction! ----- Method: PluggableWindowSpec>>closeAction: (in category 'accessing') ----- closeAction: aSymbol "Answer the receiver's closeAction" closeAction := aSymbol.! ----- Method: PluggableWindowSpec>>extent (in category 'accessing') ----- extent "Answer the window's (initial) extent" ^extent! ----- Method: PluggableWindowSpec>>extent: (in category 'accessing') ----- extent: aPoint "Indicate the window's (initial) extent" extent := aPoint! ----- Method: PluggableWindowSpec>>isDialog (in category 'accessing') ----- isDialog ^isDialog ifNil: [false] ! ----- Method: PluggableWindowSpec>>isDialog: (in category 'accessing') ----- isDialog: val isDialog := val ! ----- Method: PluggableWindowSpec>>label (in category 'accessing') ----- label "Answer the selector for retrieving the window's label" ^label! ----- Method: PluggableWindowSpec>>label: (in category 'accessing') ----- label: aString "Indicate the selector for retrieving the window's label" label := aString! ----- Method: PluggableWindowSpec>>multiWindowStyle (in category 'accessing') ----- multiWindowStyle "Answer the value of multiWindowStyle, a Symbol or nil" ^multiWindowStyle! ----- Method: PluggableWindowSpec>>multiWindowStyle: (in category 'accessing') ----- multiWindowStyle: aSymbol "Set the value of multiWindowStyle, one of #labelButton or #tabbed" multiWindowStyle := aSymbol! PluggableWidgetSpec subclass: #PluggableDropDownListSpec instanceVariableNames: 'listSelector selectionSelector selectionSetter' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableDropDownListSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableDropDownList: self! ----- Method: PluggableDropDownListSpec>>listSelector (in category 'accessing') ----- listSelector "Answer the value of listSelector" ^ listSelector! ----- Method: PluggableDropDownListSpec>>listSelector: (in category 'accessing') ----- listSelector: anObject "Set the value of listSelector" listSelector := anObject! ----- Method: PluggableDropDownListSpec>>selectionSelector (in category 'accessing') ----- selectionSelector "Answer the value of selectionSelector" ^ selectionSelector! ----- Method: PluggableDropDownListSpec>>selectionSelector: (in category 'accessing') ----- selectionSelector: anObject "Set the value of selectionSelector" selectionSelector := anObject! ----- Method: PluggableDropDownListSpec>>selectionSetter (in category 'accessing') ----- selectionSetter "Answer the value of selectionSetter" ^ selectionSetter! ----- Method: PluggableDropDownListSpec>>selectionSetter: (in category 'accessing') ----- selectionSetter: anObject "Set the value of selectionSetter" selectionSetter := anObject! PluggableWidgetSpec subclass: #PluggableListSpec instanceVariableNames: 'list getIndex setIndex getSelected setSelected menu keyPress autoDeselect dragItem dropItem dropAccept doubleClick listSize listItem keystrokePreview icon vScrollBarPolicy hScrollBarPolicy' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableListSpec commentStamp: 'ar 7/15/2005 11:54' prior: 0! A single selection list element. Instance variables: list The selector to retrieve the list elements. getIndex The selector to retrieve the list selection index. setIndex The selector to set the list selection index. getSelected The selector to retrieve the list selection. setSelected The selector to set the list selection. menu The selector to offer (to retrieve?) the context menu. keyPress The selector to invoke for handling keyboard shortcuts. autoDeselect Whether the list should allow automatic deselection or not. dragItem Selector to initiate a drag action on an item dropItem Selector to initiate a drop action of an item dropAccept Selector to determine whether a drop would be accepted! ----- Method: PluggableListSpec>>autoDeselect (in category 'accessing') ----- autoDeselect "Answer whether this tree can be automatically deselected" ^autoDeselect ifNil:[true]! ----- Method: PluggableListSpec>>autoDeselect: (in category 'accessing') ----- autoDeselect: aBool "Indicate whether this tree can be automatically deselected" autoDeselect := aBool! ----- Method: PluggableListSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableList: self! ----- Method: PluggableListSpec>>doubleClick (in category 'accessing') ----- doubleClick "Answer the selector to perform when a double-click occurs" ^doubleClick! ----- Method: PluggableListSpec>>doubleClick: (in category 'accessing') ----- doubleClick: aSymbol "Set the selector to perform when a double-click occurs" doubleClick := aSymbol.! ----- Method: PluggableListSpec>>dragItem (in category 'accessing') ----- dragItem "Answer the selector for dragging an item" ^dragItem! ----- Method: PluggableListSpec>>dragItem: (in category 'accessing') ----- dragItem: aSymbol "Set the selector for dragging an item" dragItem := aSymbol! ----- Method: PluggableListSpec>>dropAccept (in category 'accessing') ----- dropAccept "Answer the selector to determine whether a drop would be accepted" ^dropAccept! ----- Method: PluggableListSpec>>dropAccept: (in category 'accessing') ----- dropAccept: aSymbol "Answer the selector to determine whether a drop would be accepted" dropAccept := aSymbol.! ----- Method: PluggableListSpec>>dropItem (in category 'accessing') ----- dropItem "Answer the selector for dropping an item" ^dropItem! ----- Method: PluggableListSpec>>dropItem: (in category 'accessing') ----- dropItem: aSymbol "Set the selector for dropping an item" dropItem := aSymbol! ----- Method: PluggableListSpec>>getIndex (in category 'accessing') ----- getIndex "Answer the selector for retrieving the list's selection index" ^getIndex! ----- Method: PluggableListSpec>>getIndex: (in category 'accessing') ----- getIndex: aSymbol "Indicate the selector for retrieving the list's selection index" getIndex := aSymbol! ----- Method: PluggableListSpec>>getSelected (in category 'accessing') ----- getSelected "Answer the selector for retrieving the list selection" ^getSelected! ----- Method: PluggableListSpec>>getSelected: (in category 'accessing') ----- getSelected: aSymbol "Indicate the selector for retrieving the list selection" getSelected := aSymbol! ----- Method: PluggableListSpec>>hScrollBarPolicy (in category 'accessing') ----- hScrollBarPolicy ^ hScrollBarPolicy! ----- Method: PluggableListSpec>>hScrollBarPolicy: (in category 'accessing') ----- hScrollBarPolicy: aSymbol "#always, #never, #whenNeeded" hScrollBarPolicy := aSymbol.! ----- Method: PluggableListSpec>>icon (in category 'accessing') ----- icon ^ icon! ----- Method: PluggableListSpec>>icon: (in category 'accessing') ----- icon: aSelector icon := aSelector! ----- Method: PluggableListSpec>>keyPress (in category 'accessing') ----- keyPress "Answer the selector for invoking the list's keyPress handler" ^keyPress! ----- Method: PluggableListSpec>>keyPress: (in category 'accessing') ----- keyPress: aSymbol "Indicate the selector for invoking the list's keyPress handler" keyPress := aSymbol! ----- Method: PluggableListSpec>>keystrokePreview (in category 'accessing') ----- keystrokePreview "Answer the selector to determine whether to allow the model a preview of keystrokes" ^ keystrokePreview! ----- Method: PluggableListSpec>>keystrokePreview: (in category 'accessing') ----- keystrokePreview: aSymbol "The selector to determine whether to allow the model a preview of keystrokes" keystrokePreview := aSymbol.! ----- Method: PluggableListSpec>>list (in category 'accessing') ----- list "Answer the selector for retrieving the list contents" ^list! ----- Method: PluggableListSpec>>list: (in category 'accessing') ----- list: aSymbol "Indicate the selector for retrieving the list contents" list := aSymbol.! ----- Method: PluggableListSpec>>listItem (in category 'accessing') ----- listItem "Answer the selector for retrieving the list element" ^listItem! ----- Method: PluggableListSpec>>listItem: (in category 'accessing') ----- listItem: aSymbol "Indicate the selector for retrieving the list element" listItem := aSymbol.! ----- Method: PluggableListSpec>>listSize (in category 'accessing') ----- listSize "Answer the selector for retrieving the list size" ^listSize! ----- Method: PluggableListSpec>>listSize: (in category 'accessing') ----- listSize: aSymbol "Indicate the selector for retrieving the list size" listSize := aSymbol.! ----- Method: PluggableListSpec>>menu (in category 'accessing') ----- menu "Answer the selector for retrieving the list's menu" ^menu! ----- Method: PluggableListSpec>>menu: (in category 'accessing') ----- menu: aSymbol "Indicate the selector for retrieving the list's menu" menu := aSymbol! ----- Method: PluggableListSpec>>setIndex (in category 'accessing') ----- setIndex "Answer the selector for setting the list's selection index" ^setIndex! ----- Method: PluggableListSpec>>setIndex: (in category 'accessing') ----- setIndex: aSymbol "Answer the selector for setting the list's selection index" setIndex := aSymbol! ----- Method: PluggableListSpec>>setSelected (in category 'accessing') ----- setSelected "Answer the selector for setting the list selection" ^setSelected! ----- Method: PluggableListSpec>>setSelected: (in category 'accessing') ----- setSelected: aSymbol "Indicate the selector for setting the list selection" setSelected := aSymbol! ----- Method: PluggableListSpec>>vScrollBarPolicy (in category 'accessing') ----- vScrollBarPolicy ^ vScrollBarPolicy! ----- Method: PluggableListSpec>>vScrollBarPolicy: (in category 'accessing') ----- vScrollBarPolicy: aSymbol "#always, #never, #whenNeeded" vScrollBarPolicy := aSymbol.! PluggableListSpec subclass: #PluggableMultiSelectionListSpec instanceVariableNames: 'getSelectionList setSelectionList' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableMultiSelectionListSpec commentStamp: 'ar 2/12/2005 13:31' prior: 0! PluggableMultiSelectionListSpec specifies a list with multiple selection behavior. Instance variables: getSelectionList The message to retrieve the multiple selections. setSelectionList The message to indicate multiple selections.! PluggableMultiSelectionListSpec subclass: #PluggableAlternateMultiSelectionListSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableAlternateMultiSelectionListSpec>>buildWith: (in category 'building') ----- buildWith: builder ^ builder buildPluggableAlternateMultiSelectionList: self! ----- Method: PluggableMultiSelectionListSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableMultiSelectionList: self! ----- Method: PluggableMultiSelectionListSpec>>getSelectionList (in category 'accessing') ----- getSelectionList "Answer the message to retrieve the multiple selections" ^getSelectionList! ----- Method: PluggableMultiSelectionListSpec>>getSelectionList: (in category 'accessing') ----- getSelectionList: aSymbol "Indicate the message to retrieve the multiple selections" getSelectionList := aSymbol! ----- Method: PluggableMultiSelectionListSpec>>setSelectionList (in category 'accessing') ----- setSelectionList "Answer the message to indicate multiple selections" ^setSelectionList! ----- Method: PluggableMultiSelectionListSpec>>setSelectionList: (in category 'accessing') ----- setSelectionList: aSymbol "Indicate the message to indicate multiple selections" setSelectionList := aSymbol! PluggableWidgetSpec subclass: #PluggableSpacerSpec instanceVariableNames: 'extent' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! ----- Method: PluggableSpacerSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableSpacer: self! ----- Method: PluggableSpacerSpec>>color (in category 'accessing') ----- color ^ super color ifNil: [Color transparent]! ----- Method: PluggableSpacerSpec>>extent (in category 'layout hints') ----- extent ^ extent ifNil: [5@5]! ----- Method: PluggableSpacerSpec>>extent: (in category 'layout hints') ----- extent: aPoint extent := aPoint.! ----- Method: PluggableSpacerSpec>>fillSpaceHorizontally (in category 'convenience') ----- fillSpaceHorizontally self horizontalResizing: #spaceFill.! ----- Method: PluggableSpacerSpec>>fillSpaceVertically (in category 'convenience') ----- fillSpaceVertically self verticalResizing: #spaceFill.! ----- Method: PluggableSpacerSpec>>horizontalResizing (in category 'accessing') ----- horizontalResizing ^ super horizontalResizing ifNil: [#rigid]! ----- Method: PluggableSpacerSpec>>verticalResizing (in category 'accessing') ----- verticalResizing ^ super verticalResizing ifNil: [#rigid]! PluggableWidgetSpec subclass: #PluggableTextSpec instanceVariableNames: 'getText setText selection menu askBeforeDiscardingEdits editText indicateUnacceptedChanges stylerClass font readOnly softLineWrap hardLineWrap' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableTextSpec commentStamp: 'ar 2/11/2005 21:58' prior: 0! A text editor. Instance variables: getText The selector to retrieve the text. setText The selector to set the text. selection The selector to retrieve the text selection. menu The selector to offer (to retrieve?) the context menu. color The selector to retrieve the background color. ! PluggableTextSpec subclass: #PluggableCodePaneSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableCodePaneSpec commentStamp: 'ar 8/18/2009 00:02' prior: 0! A PluggableTextSpec specifically intended to edit code. Uses Syntax-Highlighting.! ----- Method: PluggableCodePaneSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableCodePane: self! ----- Method: PluggableCodePaneSpec>>font (in category 'accessing') ----- font ^ font ifNil: [Preferences standardCodeFont]! ----- Method: PluggableCodePaneSpec>>stylerClass (in category 'accessing') ----- stylerClass ^ super stylerClass ifNil: [Smalltalk classNamed: 'SHTextStylerST80']! PluggableTextSpec subclass: #PluggableInputFieldSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableInputFieldSpec commentStamp: 'ar 2/12/2005 23:13' prior: 0! PluggableInputField is intended as a HINT for the builder that this widget will be used as a single line input field. Unless explicitly supported it will be automatically substituted by PluggableText.! ----- Method: PluggableInputFieldSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableInputField: self! ----- Method: PluggableInputFieldSpec>>hardLineWrap (in category 'accessing') ----- hardLineWrap ^ false! ----- Method: PluggableInputFieldSpec>>softLineWrap (in category 'accessing') ----- softLineWrap ^ super softLineWrap ifNil: [false]! ----- Method: PluggableTextSpec>>askBeforeDiscardingEdits (in category 'accessing') ----- askBeforeDiscardingEdits ^askBeforeDiscardingEdits ifNil:[true]! ----- Method: PluggableTextSpec>>askBeforeDiscardingEdits: (in category 'accessing') ----- askBeforeDiscardingEdits: aBool askBeforeDiscardingEdits := aBool! ----- Method: PluggableTextSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableText: self! ----- Method: PluggableTextSpec>>editText (in category 'accessing') ----- editText ^ editText! ----- Method: PluggableTextSpec>>editText: (in category 'accessing') ----- editText: aSymbol "Answer the selector for getting informed about any modifications of the text." editText := aSymbol! ----- Method: PluggableTextSpec>>font (in category 'accessing') ----- font ^ font ifNil: [Preferences standardDefaultTextFont]! ----- Method: PluggableTextSpec>>font: (in category 'accessing') ----- font: aFont font := aFont.! ----- Method: PluggableTextSpec>>getText (in category 'accessing') ----- getText "Answer the selector for retrieving the text" ^getText! ----- Method: PluggableTextSpec>>getText: (in category 'accessing') ----- getText: aSymbol "Answer the selector for retrieving the text" getText := aSymbol! ----- Method: PluggableTextSpec>>hardLineWrap (in category 'accessing') ----- hardLineWrap ^ hardLineWrap! ----- Method: PluggableTextSpec>>hardLineWrap: (in category 'accessing') ----- hardLineWrap: aBoolean hardLineWrap := aBoolean.! ----- Method: PluggableTextSpec>>indicateUnacceptedChanges (in category 'accessing') ----- indicateUnacceptedChanges ^ indicateUnacceptedChanges ifNil: [true]! ----- Method: PluggableTextSpec>>indicateUnacceptedChanges: (in category 'accessing') ----- indicateUnacceptedChanges: aBoolean indicateUnacceptedChanges := aBoolean.! ----- Method: PluggableTextSpec>>menu (in category 'accessing') ----- menu "Answer the selector for retrieving the text's menu" ^menu! ----- Method: PluggableTextSpec>>menu: (in category 'accessing') ----- menu: aSymbol "Indicate the selector for retrieving the text's menu" menu := aSymbol! ----- Method: PluggableTextSpec>>readOnly (in category 'accessing') ----- readOnly ^ readOnly ifNil: [false]! ----- Method: PluggableTextSpec>>readOnly: (in category 'accessing') ----- readOnly: aBoolean readOnly := aBoolean.! ----- Method: PluggableTextSpec>>selection (in category 'accessing') ----- selection "Answer the selector for retrieving the text selection" ^selection! ----- Method: PluggableTextSpec>>selection: (in category 'accessing') ----- selection: aSymbol "Indicate the selector for retrieving the text selection" selection := aSymbol! ----- Method: PluggableTextSpec>>setText (in category 'accessing') ----- setText "Answer the selector for setting the text" ^setText! ----- Method: PluggableTextSpec>>setText: (in category 'accessing') ----- setText: aSymbol "Answer the selector for setting the text" setText := aSymbol! ----- Method: PluggableTextSpec>>softLineWrap (in category 'accessing') ----- softLineWrap ^ softLineWrap! ----- Method: PluggableTextSpec>>softLineWrap: (in category 'accessing') ----- softLineWrap: aBoolean softLineWrap := aBoolean.! ----- Method: PluggableTextSpec>>stylerClass (in category 'accessing') ----- stylerClass ^ stylerClass! ----- Method: PluggableTextSpec>>stylerClass: (in category 'accessing') ----- stylerClass: aStylerClass stylerClass := aStylerClass.! PluggableWidgetSpec subclass: #PluggableTreeSpec instanceVariableNames: 'roots getSelectedPath setSelected getSelected setSelectedParent getChildren hasChildren label icon unusedVar menu keyPress wantsDrop dropItem dropAccept autoDeselect dragItem nodeClass columns' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !PluggableTreeSpec commentStamp: 'mvdg 3/21/2008 20:59' prior: 0! A pluggable tree widget. PluggableTrees are slightly different from lists in such that they ALWAYS store the actual objects and use the label selector to query for the label of the item. PluggableTrees also behave somewhat differently in such that they do not have a "getSelected" message but only a getSelectedPath message. The difference is that getSelectedPath is used to indicate by the model that the tree should select the appropriate path. This allows disambiguation of items. Because of this, implementations of PluggableTrees must always set their internal selection directly, e.g., rather than sending the model a setSelected message and wait for an update of the #getSelected the implementation must set the selection before sending the #setSelected message. If a client doesn't want this, it can always just signal a change of getSelectedPath to revert to whatever is needed. Instance variables: roots The message to retrieve the roots of the tree. getSelectedPath The message to retrieve the selected path in the tree. setSelected The message to set the selected item in the tree. getChildren The message to retrieve the children of an item hasChildren The message to query for children of an item label The message to query for the label of an item. icon The message to query for the icon of an item. help The message to query for the help of an item. menu The message to query for the tree's menu keyPress The message to process a keystroke. wantsDrop The message to query whether a drop might be accepted. dropItem The message to drop an item. enableDrag Enable dragging from this tree. autoDeselect Whether the tree should allow automatic deselection or not. unusedVar (unused) This variable is a placeholder to fix problems with loading packages in 3.10.! ----- Method: PluggableTreeSpec>>autoDeselect (in category 'accessing') ----- autoDeselect "Answer whether this tree can be automatically deselected" ^autoDeselect ifNil:[true]! ----- Method: PluggableTreeSpec>>autoDeselect: (in category 'accessing') ----- autoDeselect: aBool "Indicate whether this tree can be automatically deselected" autoDeselect := aBool.! ----- Method: PluggableTreeSpec>>buildWith: (in category 'building') ----- buildWith: builder ^builder buildPluggableTree: self! ----- Method: PluggableTreeSpec>>columns (in category 'accessing') ----- columns ^ columns! ----- Method: PluggableTreeSpec>>columns: (in category 'accessing') ----- columns: columnSpecs columns := columnSpecs.! ----- Method: PluggableTreeSpec>>dragItem (in category 'accessing') ----- dragItem ^ dragItem.! ----- Method: PluggableTreeSpec>>dragItem: (in category 'accessing') ----- dragItem: aSymbol "Set the selector for dragging an item" dragItem := aSymbol! ----- Method: PluggableTreeSpec>>dropAccept (in category 'accessing') ----- dropAccept "Answer the selector for querying the receiver about accepting drops" ^dropAccept! ----- Method: PluggableTreeSpec>>dropAccept: (in category 'accessing') ----- dropAccept: aSymbol "Set the selector for querying the receiver about accepting drops" dropAccept := aSymbol! ----- Method: PluggableTreeSpec>>dropItem (in category 'accessing') ----- dropItem "Answer the selector for invoking the tree's dragDrop handler" ^dropItem! ----- Method: PluggableTreeSpec>>dropItem: (in category 'accessing') ----- dropItem: aSymbol "Indicate the selector for invoking the tree's dragDrop handler" dropItem := aSymbol! ----- Method: PluggableTreeSpec>>getChildren (in category 'accessing') ----- getChildren "Answer the message to get the children of this tree" ^getChildren! ----- Method: PluggableTreeSpec>>getChildren: (in category 'accessing') ----- getChildren: aSymbol "Indicate the message to retrieve the children of this tree" getChildren := aSymbol! ----- Method: PluggableTreeSpec>>getSelected (in category 'accessing') ----- getSelected ^ getSelected! ----- Method: PluggableTreeSpec>>getSelected: (in category 'accessing') ----- getSelected: aSymbol "Indicate a single node in the tree. Only works if that node is visible, too. Use #getSelectedPath otherwise." getSelected := aSymbol.! ----- Method: PluggableTreeSpec>>getSelectedPath (in category 'accessing') ----- getSelectedPath "Answer the message to retrieve the selection of this tree" ^getSelectedPath! ----- Method: PluggableTreeSpec>>getSelectedPath: (in category 'accessing') ----- getSelectedPath: aSymbol "Indicate the message to retrieve the selection of this tree" getSelectedPath := aSymbol! ----- Method: PluggableTreeSpec>>hasChildren (in category 'accessing') ----- hasChildren "Answer the message to get the existence of children in this tree" ^hasChildren! ----- Method: PluggableTreeSpec>>hasChildren: (in category 'accessing') ----- hasChildren: aSymbol "Indicate the message to retrieve the existence children in this tree" hasChildren := aSymbol! ----- Method: PluggableTreeSpec>>icon (in category 'accessing') ----- icon "Answer the message to get the icons of this tree" ^icon! ----- Method: PluggableTreeSpec>>icon: (in category 'accessing') ----- icon: aSymbol "Indicate the message to retrieve the icon of this tree" icon := aSymbol! ----- Method: PluggableTreeSpec>>keyPress (in category 'accessing') ----- keyPress "Answer the selector for invoking the tree's keyPress handler" ^keyPress! ----- Method: PluggableTreeSpec>>keyPress: (in category 'accessing') ----- keyPress: aSymbol "Indicate the selector for invoking the tree's keyPress handler" keyPress := aSymbol! ----- Method: PluggableTreeSpec>>label (in category 'accessing') ----- label "Answer the message to get the labels of this tree" ^label! ----- Method: PluggableTreeSpec>>label: (in category 'accessing') ----- label: aSymbol "Indicate the message to retrieve the labels of this tree" label := aSymbol! ----- Method: PluggableTreeSpec>>menu (in category 'accessing') ----- menu "Answer the message to get the menus of this tree" ^menu! ----- Method: PluggableTreeSpec>>menu: (in category 'accessing') ----- menu: aSymbol "Indicate the message to retrieve the menus of this tree" menu := aSymbol! ----- Method: PluggableTreeSpec>>nodeClass (in category 'accessing') ----- nodeClass ^ nodeClass! ----- Method: PluggableTreeSpec>>nodeClass: (in category 'accessing') ----- nodeClass: aListWrapperClass nodeClass := aListWrapperClass.! ----- Method: PluggableTreeSpec>>roots (in category 'accessing') ----- roots "Answer the message to retrieve the roots of this tree" ^roots! ----- Method: PluggableTreeSpec>>roots: (in category 'accessing') ----- roots: aSymbol "Indicate the message to retrieve the roots of this tree" roots := aSymbol! ----- Method: PluggableTreeSpec>>setSelected (in category 'accessing') ----- setSelected "Answer the message to set the selection of this tree" ^setSelected! ----- Method: PluggableTreeSpec>>setSelected: (in category 'accessing') ----- setSelected: aSymbol "Indicate the message to set the selection of this tree" setSelected := aSymbol! ----- Method: PluggableTreeSpec>>setSelectedParent (in category 'accessing') ----- setSelectedParent ^ setSelectedParent! ----- Method: PluggableTreeSpec>>setSelectedParent: (in category 'accessing') ----- setSelectedParent: aSymbol setSelectedParent := aSymbol! ----- Method: PluggableTreeSpec>>wantsDrop (in category 'accessing') ----- wantsDrop "Answer the selector for invoking the tree's wantsDrop handler" ^wantsDrop! ----- Method: PluggableTreeSpec>>wantsDrop: (in category 'accessing') ----- wantsDrop: aSymbol "Indicate the selector for invoking the tree's wantsDrop handler" wantsDrop := aSymbol! ----- Method: PluggableWidgetSpec>>color (in category 'accessing') ----- color "Answer the selector for retrieving the button's color" ^color! ----- Method: PluggableWidgetSpec>>color: (in category 'accessing') ----- color: aSymbol "Indicate the selector for retrieving the button's color" color := aSymbol! ----- Method: PluggableWidgetSpec>>frame (in category 'accessing') ----- frame "Answer the receiver's layout frame" ^frame! ----- Method: PluggableWidgetSpec>>frame: (in category 'accessing') ----- frame: aRectangle "Indicate the receiver's layout frame" frame := aRectangle! ----- Method: PluggableWidgetSpec>>horizontalResizing (in category 'layout hints') ----- horizontalResizing ^ horizontalResizing! ----- Method: PluggableWidgetSpec>>horizontalResizing: (in category 'layout hints') ----- horizontalResizing: aSymbol "#rigid, #spaceFill, #shrinkWrap" horizontalResizing := aSymbol.! ----- Method: PluggableWidgetSpec>>margin (in category 'layout hints') ----- margin "Space outside the widgets border. See: http://www.w3.org/wiki/The_CSS_layout_model_-_boxes_borders_margins_padding" ^ margin! ----- Method: PluggableWidgetSpec>>margin: (in category 'layout hints') ----- margin: numberOrPointOrRectangle margin := numberOrPointOrRectangle.! ----- Method: PluggableWidgetSpec>>minimumExtent (in category 'layout hints') ----- minimumExtent ^ minimumExtent ifNil: [-1 @ -1]! ----- Method: PluggableWidgetSpec>>minimumExtent: (in category 'layout hints') ----- minimumExtent: aPoint minimumExtent := aPoint.! ----- Method: PluggableWidgetSpec>>minimumHeight (in category 'layout hints') ----- minimumHeight ^ self minimumExtent y! ----- Method: PluggableWidgetSpec>>minimumHeight: (in category 'layout hints') ----- minimumHeight: aNumber self minimumExtent: self minimumExtent x @ aNumber.! ----- Method: PluggableWidgetSpec>>minimumWidth (in category 'layout hints') ----- minimumWidth ^ self minimumExtent x! ----- Method: PluggableWidgetSpec>>minimumWidth: (in category 'layout hints') ----- minimumWidth: aNumber self minimumExtent: aNumber @ self minimumExtent y.! ----- Method: PluggableWidgetSpec>>model (in category 'accessing') ----- model "Answer the model for which this widget should be built" ^model! ----- Method: PluggableWidgetSpec>>model: (in category 'accessing') ----- model: aModel "Indicate the model for which this widget should be built" model := aModel.! ----- Method: PluggableWidgetSpec>>padding (in category 'layout hints') ----- padding "Space inside the widget's border. See: http://www.w3.org/wiki/The_CSS_layout_model_-_boxes_borders_margins_padding" ^ padding! ----- Method: PluggableWidgetSpec>>padding: (in category 'layout hints') ----- padding: numberOrPointOrRectangle padding := numberOrPointOrRectangle.! ----- Method: PluggableWidgetSpec>>verticalResizing (in category 'layout hints') ----- verticalResizing ^ verticalResizing! ----- Method: PluggableWidgetSpec>>verticalResizing: (in category 'layout hints') ----- verticalResizing: aSymbol "#rigid, #spaceFill, #shrinkWrap" verticalResizing := aSymbol.! ----- Method: ToolBuilderSpec>>buildWith: (in category 'building') ----- buildWith: aBuilder ^self subclassResponsibility! ----- Method: ToolBuilderSpec>>help (in category 'accessing') ----- help "Answer the message to get the help texts of this element." ^ help! ----- Method: ToolBuilderSpec>>help: (in category 'accessing') ----- help: aSymbol "Indicate the message to retrieve the help texts of this element." help := aSymbol! ----- Method: ToolBuilderSpec>>name (in category 'accessing') ----- name ^ name! ----- Method: ToolBuilderSpec>>name: (in category 'accessing') ----- name: anObject name := anObject! Object subclass: #UIManager instanceVariableNames: 'builderClass' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-Kernel'! !UIManager commentStamp: 'dtl 5/2/2010 16:06' prior: 0! UIManager is a dispatcher for various user interface requests, such as menu and dialog interactions. An instance of UIManager is associated with each Project to implement the appropriate functions for Morphic, MVC or other user interfaces.! ----- Method: UIManager class>>default (in category 'class initialization') ----- default ^ Project current uiManager! ----- Method: UIManager class>>getDefault (in category 'class initialization') ----- getDefault "Ensure that a more specific manager can always be made by subclassing a tool builder and implementing a more specific way of reacting to #isActiveManager. For example, a BobsUIManager can subclass MorphicUIManager and (if enabled, say Preferences useBobsUI) will be considered before the parent (generic MorphicUIManager)." ^ (self allSubclasses detect: [:any | any isActiveManager and: [any subclasses noneSatisfy: [:sub | sub isActiveManager]]] ifNone: []) ifNotNilDo: [:mgrClass | mgrClass new]! ----- Method: UIManager class>>isActiveManager (in category 'class initialization') ----- isActiveManager "Answer whether I should act as the active ui manager" ^false! ----- Method: UIManager>>builderClass (in category 'builder') ----- builderClass "Answer the kind of tool builder to use, possibly influenced by project preferences" ^ builderClass ifNil: [ builderClass := ToolBuilder findDefault ]! ----- Method: UIManager>>builderClass: (in category 'accessing') ----- builderClass: aClass builderClass := aClass! ----- Method: UIManager>>chooseClassOrTrait (in category 'ui requests') ----- chooseClassOrTrait "Let the user choose a Class or Trait" ^self chooseClassOrTrait: 'Class name or fragment?'! ----- Method: UIManager>>chooseClassOrTrait: (in category 'ui requests') ----- chooseClassOrTrait: label "Let the user choose a Class or Trait" ^self chooseClassOrTrait: label from: Smalltalk environment! ----- Method: UIManager>>chooseClassOrTrait:from: (in category 'ui requests') ----- chooseClassOrTrait: label from: environment "Let the user choose a Class or Trait." | pattern | pattern := self request: label. ^ self classOrTraitFrom: environment pattern: pattern label: label ! ----- Method: UIManager>>chooseDirectory (in category 'ui requests') ----- chooseDirectory "Let the user choose a directory" ^self chooseDirectoryFrom: FileDirectory default! ----- Method: UIManager>>chooseDirectory: (in category 'ui requests') ----- chooseDirectory: label "Let the user choose a directory" ^self chooseDirectory: label from: FileDirectory default! ----- Method: UIManager>>chooseDirectory:from: (in category 'ui requests') ----- chooseDirectory: label from: dir "Let the user choose a directory" ^self subclassResponsibility! ----- Method: UIManager>>chooseDirectoryFrom: (in category 'ui requests') ----- chooseDirectoryFrom: dir "Let the user choose a directory" ^self chooseDirectory: nil from: dir! ----- Method: UIManager>>chooseFileMatching: (in category 'ui requests') ----- chooseFileMatching: patterns "Let the user choose a file matching the given patterns" ^self chooseFileMatching: patterns label: nil! ----- Method: UIManager>>chooseFileMatching:label: (in category 'ui requests') ----- chooseFileMatching: patterns label: labelString "Let the user choose a file matching the given patterns" ^self subclassResponsibility! ----- Method: UIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') ----- chooseFont: titleString for: aModel setSelector: setSelector getSelector: getSelector "Open a font-chooser for the given model"! ----- Method: UIManager>>chooseFrom: (in category 'ui requests') ----- chooseFrom: aList "Choose an item from the given list. Answer the index of the selected item." ^self chooseFrom: aList lines: #()! ----- Method: UIManager>>chooseFrom:lines: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray "Choose an item from the given list. Answer the index of the selected item." ^self chooseFrom: aList lines: linesArray title: ''! ----- Method: UIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the index of the selected item." ^self subclassResponsibility! ----- Method: UIManager>>chooseFrom:title: (in category 'ui requests') ----- chooseFrom: aList title: aString "Choose an item from the given list. Answer the index of the selected item." ^self chooseFrom: aList lines: #() title: aString! ----- Method: UIManager>>chooseFrom:values: (in category 'ui requests') ----- chooseFrom: labelList values: valueList "Choose an item from the given list. Answer the selected item." ^self chooseFrom: labelList values: valueList lines: #()! ----- Method: UIManager>>chooseFrom:values:lines: (in category 'ui requests') ----- chooseFrom: labelList values: valueList lines: linesArray "Choose an item from the given list. Answer the selected item." ^self chooseFrom: labelList values: valueList lines: linesArray title: ''! ----- Method: UIManager>>chooseFrom:values:lines:title: (in category 'ui requests') ----- chooseFrom: labelList values: valueList lines: linesArray title: aString "Choose an item from the given list. Answer the selected item." ^self subclassResponsibility! ----- Method: UIManager>>chooseFrom:values:title: (in category 'ui requests') ----- chooseFrom: labelList values: valueList title: aString "Choose an item from the given list. Answer the selected item." ^self chooseFrom: labelList values: valueList lines: #() title: aString! ----- Method: UIManager>>chooseMultipleFrom: (in category 'ui requests') ----- chooseMultipleFrom: aList "Choose one or more items from the given list. Answer the indices of the selected items." ^ self chooseMultipleFrom: aList lines: #()! ----- Method: UIManager>>chooseMultipleFrom:lines: (in category 'ui requests') ----- chooseMultipleFrom: aList lines: linesArray "Choose one or more items from the given list. Answer the indices of the selected items." ^ self chooseMultipleFrom: aList lines: linesArray title: ''! ----- Method: UIManager>>chooseMultipleFrom:lines:title: (in category 'ui requests') ----- chooseMultipleFrom: aList lines: linesArray title: aString "Choose one or more items from the given list. Answer the indices of the selected items." ^ (self chooseFrom: aList lines: linesArray title: aString) in: [:result | result = 0 ifTrue: [#()] ifFalse: [{result}]]! ----- Method: UIManager>>chooseMultipleFrom:title: (in category 'ui requests') ----- chooseMultipleFrom: aList title: aString "Choose one or more items from the given list. Answer the indices of the selected items." ^self chooseMultipleFrom: aList lines: #() title: aString! ----- Method: UIManager>>chooseMultipleFrom:values: (in category 'ui requests') ----- chooseMultipleFrom: labelList values: valueList "Choose one or more items from the given list. Answer the selected items." ^ self chooseMultipleFrom: labelList values: valueList lines: #()! ----- Method: UIManager>>chooseMultipleFrom:values:lines: (in category 'ui requests') ----- chooseMultipleFrom: labelList values: valueList lines: linesArray "Choose one or more items from the given list. Answer the selected items." ^ self chooseMultipleFrom: labelList values: valueList lines: linesArray title: ''! ----- Method: UIManager>>chooseMultipleFrom:values:lines:title: (in category 'ui requests') ----- chooseMultipleFrom: labelList values: valueList lines: linesArray title: aString "Choose one or more items from the given list. Answer the selected items." ^ (self chooseFrom: labelList values: valueList lines: linesArray title: aString) ifNil: [#()] ifNotNil: [:resultValue | {resultValue}]! ----- Method: UIManager>>chooseMultipleFrom:values:title: (in category 'ui requests') ----- chooseMultipleFrom: labelList values: valueList title: aString "Choose one or more items from the given list. Answer the selected items." ^ self chooseMultipleFrom: labelList values: valueList lines: #() title: aString! ----- Method: UIManager>>classFromPattern:withCaption: (in category 'system introspecting') ----- classFromPattern: pattern withCaption: aCaption "If there is a class or trait whose name exactly given by pattern, return it. If there is only one class or trait in the system whose name matches pattern, return it. Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. This method ignores separator characters in the pattern" ^self classOrTraitFrom: Smalltalk environment pattern: pattern label: aCaption " self classFromPattern: 'CharRecog' withCaption: '' self classFromPattern: 'rRecog' withCaption: '' self classFromPattern: 'znak' withCaption: '' self classFromPattern: 'orph' withCaption: '' self classFromPattern: 'TCompil' withCaption: '' " ! ----- Method: UIManager>>classOrTraitFrom:pattern:label: (in category 'system introspecting') ----- classOrTraitFrom: environment pattern: pattern label: label "If there is a class or trait whose name exactly given by pattern, return it. If there is only one class or trait in the given environment whose name matches pattern, return it. Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. This method ignores separator characters in the pattern" | toMatch potentialNames names exactMatch lines reducedIdentifiers selectedIndex | toMatch := pattern copyWithoutAll: Character separators. toMatch ifEmpty: [ ^nil ]. "If there's a class or trait named as pattern, then return it." Symbol hasInterned: pattern ifTrue: [ :symbol | environment at: symbol ifPresent: [ :maybeClassOrTrait | ((maybeClassOrTrait isKindOf: Class) or: [ maybeClassOrTrait isTrait ]) ifTrue: [ ^maybeClassOrTrait ] ] ]. "No exact match, look for potential matches." toMatch := pattern asLowercase copyWithout: $.. potentialNames := (environment classAndTraitNames) asOrderedCollection. names := pattern last = $. "This is some old hack, using String>>#match: may be better." ifTrue: [ potentialNames select: [ :each | each asLowercase = toMatch ] ] ifFalse: [ potentialNames select: [ :each | each includesSubstring: toMatch caseSensitive: false ] ]. exactMatch := names detect: [ :each | each asLowercase = toMatch ] ifNone: [ nil ]. lines := OrderedCollection new. exactMatch ifNotNil: [ lines add: 1 ]. "Also try some fuzzy matching." reducedIdentifiers := pattern suggestedTypeNames select: [ :each | potentialNames includes: each ]. reducedIdentifiers ifNotEmpty: [ names addAll: reducedIdentifiers. lines add: 1 + names size + reducedIdentifiers size ]. "Let the user select if there's more than one possible match. This may give surprising results." selectedIndex := names size = 1 ifTrue: [ 1 ] ifFalse: [ exactMatch ifNotNil: [ names addFirst: exactMatch ]. self chooseFrom: names lines: lines title: label ]. selectedIndex = 0 ifTrue: [ ^nil ]. ^environment at: (names at: selectedIndex) asSymbol! ----- Method: UIManager>>confirm: (in category 'ui requests') ----- 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." ^self subclassResponsibility! ----- Method: UIManager>>confirm:orCancel: (in category 'ui requests') ----- confirm: aString 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." ^self subclassResponsibility! ----- Method: UIManager>>confirm:orCancel:title: (in category 'ui requests') ----- confirm: aString orCancel: cancelBlock title: titleString "Put up a yes/no/cancel menu with caption aString, and titleString to label the dialog. 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." ^self subclassResponsibility! ----- Method: UIManager>>confirm:title: (in category 'ui requests') ----- confirm: queryString title: titleString "Put up a yes/no menu with caption queryString, and titleString to label the dialog. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." ^self subclassResponsibility! ----- Method: UIManager>>confirm:title:trueChoice:falseChoice: (in category 'ui requests') ----- confirm: queryString title: titleString trueChoice: trueChoice falseChoice: falseChoice "Put up a yes/no menu with caption queryString, and titleString to label the dialog. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it is the false-choice. This is a modal question -- the user must respond one way or the other." ^self subclassResponsibility! ----- Method: UIManager>>confirm:trueChoice:falseChoice: (in category 'ui requests') ----- confirm: queryString trueChoice: trueChoice falseChoice: falseChoice "Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. This is a modal question -- the user must respond one way or the other." ^self subclassResponsibility! ----- Method: UIManager>>displayProgress:at:from:to:during: (in category 'ui requests') ----- displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock "Display titleString as a caption over a progress bar while workBlock is evaluated." ^self subclassResponsibility! ----- Method: UIManager>>edit: (in category 'ui requests') ----- edit: aText "Open an editor on the given string/text" ^self edit: aText label: nil! ----- Method: UIManager>>edit:label: (in category 'ui requests') ----- edit: aText label: labelString "Open an editor on the given string/text" ^self edit: aText label: labelString accept: nil! ----- Method: UIManager>>edit:label:accept: (in category 'ui requests') ----- edit: aText label: labelString accept: anAction "Open an editor on the given string/text" ^self subclassResponsibility! ----- Method: UIManager>>inform: (in category 'ui requests') ----- inform: aString "Display a message for the user to read and then dismiss" ^self subclassResponsibility! ----- Method: UIManager>>informUser:during: (in category 'ui requests') ----- informUser: aString during: aBlock "Display a message above (or below if insufficient room) the cursor during execution of the given block. UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait]. " ^self informUserDuring:[:bar| bar value: aString. aBlock value].! ----- Method: UIManager>>informUserDuring: (in category 'ui requests') ----- informUserDuring: aBlock "Display a message above (or below if insufficient room) the cursor during execution of the given block. UIManager default informUserDuring:[:bar| #(one two three) do:[:info| bar value: info. (Delay forSeconds: 1) wait]]" ^self subclassResponsibility! ----- Method: UIManager>>multiLineRequest:centerAt:initialAnswer:answerHeight: (in category 'ui requests') ----- 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." ^self subclassResponsibility! ----- Method: UIManager>>newDisplayDepthNoRestore: (in category 'display') ----- newDisplayDepthNoRestore: pixelSize self subclassResponsibility.! ----- Method: UIManager>>request: (in category 'ui requests') ----- 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." ^self request: queryString initialAnswer: ''! ----- Method: UIManager>>request:initialAnswer: (in category 'ui requests') ----- 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." ^self subclassResponsibility! ----- Method: UIManager>>request:initialAnswer:centerAt: (in category 'ui requests') ----- 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." ^self subclassResponsibility! ----- Method: UIManager>>requestPassword: (in category 'ui requests') ----- 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." ^self subclassResponsibility! ----- Method: UIManager>>restoreDisplay (in category 'display') ----- restoreDisplay self subclassResponsibility.! ----- Method: UIManager>>restoreDisplayAfter: (in category 'display') ----- restoreDisplayAfter: aBlock self subclassResponsibility.! ----- Method: UIManager>>screenBounds (in category 'accessing') ----- screenBounds ^ Display boundingBox! ----- Method: UIManager>>toolBuilder (in category 'builder') ----- toolBuilder ^ self builderClass new! From commits at source.squeak.org Fri Jun 5 20:20:06 2015 From: commits at source.squeak.org (commits@source.squeak.org) Date: Fri Jun 5 20:20:09 2015 Subject: [squeak-dev] Squeak 4.6: GetText-mt.37.mcz Message-ID: Chris Muller uploaded a new version of GetText to project Squeak 4.6: http://source.squeak.org/squeak46/GetText-mt.37.mcz ==================== Summary ==================== Name: GetText-mt.37 Author: mt Time: 10 May 2015, 1:57:01.667 pm UUID: 0033c111-0112-dd4f-95ac-0a56cc7a0f68 Ancestors: GetText-nice.36 Skip registering LanguageEditor in world menu for now because it is not functional at the moment. ==================== Snapshot ==================== SystemOrganization addCategory: #'GetText-Editor'! Object subclass: #GetTextExporter instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'GetText-Editor'! !GetTextExporter commentStamp: '' prior: 0! Export translations to gettext format divided into categories. "Export gettext template files" GetTextExporter new exportTemplate. "Export translation files for current locale" GetTextExporter new exportTranslator: (InternalTranslator newLocaleID: LocaleID current). "Export all gettext template and po files." GetTextExporter exportAll. ! ----- Method: GetTextExporter class>>coverageStatus (in category 'utilities') ----- coverageStatus "self coverageStatus" | keys diff | keys := self keys. diff := InternalTranslator allKnownPhrases keys difference: keys. Transcript cr; show: 'Detected keywords by GetTextExporter2: ' , keys size printString. Transcript cr; show: 'All known phrases in InternalTranslator: ' , InternalTranslator allKnownPhrases size printString. Transcript cr; show: 'Coverage: ' , (keys size / InternalTranslator allKnownPhrases size * 100.0) printString , '%'. diff inspect! ----- Method: GetTextExporter class>>exportAll (in category 'utilities') ----- exportAll "GetTextExporter2 exportAll" self new exportTemplate. InternalTranslator availableLanguageLocaleIDs do: [:each | self new exportTranslator: each translator]! ----- Method: GetTextExporter class>>exportTemplate (in category 'utilities') ----- exportTemplate "GetTextExporter2 exportTemplate" self new exportTemplate.! ----- Method: GetTextExporter class>>keys (in category 'utilities') ----- keys | categories | categories := Dictionary new. self new appendTranslations: categories. ^ categories values inject: Set new into: [:set :next | set addAll: next keys; yourself]! ----- Method: GetTextExporter class>>listAllHelp (in category 'utilities') ----- listAllHelp "self listAllHelp" | spec specs oCatalog flap flapSelectors allKeys oCatalogHelp flapHelp | oCatalog := Dictionary new. Morph withAllSubclasses do: [:aClass | (aClass class includesSelector: #descriptionForPartsBin) ifTrue: [spec := aClass descriptionForPartsBin. oCatalog at: spec formalName put: spec documentation]]. Morph withAllSubclasses do: [:aClass | (aClass class includesSelector: #supplementaryPartsDescriptions) ifTrue: [specs := aClass supplementaryPartsDescriptions. specs do: [:each | oCatalog at: each formalName put: each documentation]]]. flap := Dictionary new. flapSelectors := #(#defaultsQuadsDefiningPlugInSuppliesFlap #defaultsQuadsDefiningStackToolsFlap #defaultsQuadsDefiningSuppliesFlap #defaultsQuadsDefiningToolsFlap #defaultsQuadsDefiningWidgetsFlap #defaultsQuadsDefiningScriptingFlap ). flapSelectors do: [:selector | specs := Flaps perform: selector. specs do: [:each | flap at: each third put: each fourth]]. allKeys := oCatalog keys intersection: flap keys. allKeys asArray sort do: [:each | oCatalogHelp := oCatalog at: each ifAbsent: ['']. flapHelp := flap at: each ifAbsent: ['']. oCatalogHelp = flapHelp ifFalse: [Transcript cr; show: 'Name: ' , each. Transcript cr; show: 'O: ' , oCatalogHelp. Transcript cr; show: 'F: ' , flapHelp. Transcript cr. ]]! ----- Method: GetTextExporter class>>verifyExport (in category 'utilities') ----- verifyExport "Same as #verifyMsgID: but it writes / reads .po files actually" "GetTextExporter2 verifyExport" "InternalTranslator removeLocaleID: (LocaleID isoString: 'test-US')" | src dst localeID | localeID := LocaleID isoString: 'test-US'. self verifyMsgID: localeID. src := localeID translator. self new exportTranslator: src. InternalTranslator removeLocaleID: localeID. dst := localeID translator. GetTextImporter import: dst allDirectory: FileDirectory default! ----- Method: GetTextExporter class>>verifyMsgID: (in category 'utilities') ----- verifyMsgID: localeID "GetTextExporter2 verifyMsgID: (LocaleID isoString: 'test-US')" "InternalTranslator removeLocaleID: (LocaleID isoString: 'test-US')" "Test gettext keyword extract function without file I/O. A language named will be made. And all possible translated words are shown with extra X charactor like 'XwordX' in the language." | src | InternalTranslator removeLocaleID: localeID. src := localeID translator. self keys do: [:key | src generics at: key put: 'X' , key , 'X']! ----- Method: GetTextExporter>>appendStringReceivers:into: (in category 'private') ----- appendStringReceivers: aSymbol into: domains | literals references domainName methodReference keywords found | found := TranslatedReceiverFinder new stringReceiversWithContext: aSymbol. found do: [ :assoc | methodReference := assoc key. keywords := assoc value. domainName := (PackageOrganizer default packageOfMethod: methodReference ifNone: [nil]). domainName := domainName isNil ifTrue: [TextDomainManager defaultDomain] ifFalse: [domainName name]. literals := domains at: domainName ifAbsentPut: [Dictionary new]. keywords do: [ :literal | references := literals at: literal ifAbsentPut: [OrderedCollection new]. references add: methodReference. ]. ]. ! ----- Method: GetTextExporter>>appendTranslations: (in category 'exporting') ----- appendTranslations: domains self appendStringReceivers: #translated into: domains. self appendStringReceivers: #translatedNoop into: domains. self appendVocabularies: domains. ! ----- Method: GetTextExporter>>appendVocabularies: (in category 'private') ----- appendVocabularies: domains | literalsForDomain references domainName methodReference | EToyVocabulary allPhrasesWithContextToTranslate do: [ :r | methodReference := (MethodReference class: (r second) selector: (r third)). "domainName := self getTextDomainForPackage: (PackageOrganizer default packageOfMethod: methodReference)". domainName := 'Etoys-Tiles'. literalsForDomain := domains at: domainName ifAbsentPut: [Dictionary new]. r fourth do: [ :literal | references := literalsForDomain at: literal ifAbsentPut: [OrderedCollection new]. references add: methodReference. ]. ]. ! ----- Method: GetTextExporter>>createExtraInformation (in category 'private') ----- createExtraInformation | extras | extras := OrderedCollection new. #( 'Language name as you''d like it to appear in the Languages menu' 'Language-Name' 'Directionality of language' 'Language-Direction' ) pairsDo: [:first :second | extras add: (Array with: '' with: first with: second). ]. ^ extras! ----- Method: GetTextExporter>>createHeaders (in category 'private-headers') ----- createHeaders | headers | headers := OrderedCollection new. headers add: 'Project-Id-Version' -> 'eToys'. headers add: 'POT-Creation-Date' -> self currentDateAndTime. headers add: 'PO-Revision-Date' -> self currentDateAndTime. headers add: 'Last-Translator' -> ''. headers add: 'Language-Team' -> ''. headers add: 'MIME-Version' -> '1.0'. headers add: 'Content-Type' -> ('text/plain; charset=', stream converter class encodingNames first). headers add: 'Content-Transfer-Encoding' -> '8bit'. ^ headers! ----- Method: GetTextExporter>>currentDateAndTime (in category 'private') ----- currentDateAndTime ^ String streamContents: [:aStream | aStream nextPutAll: Date today yyyymmdd; space. Time now print24: true showSeconds: false on: aStream. aStream nextPutAll: '-0000']! ----- Method: GetTextExporter>>dirNameCategory:translator: (in category 'exporting') ----- dirNameCategory: category translator: translator "Answer a file name for the category. Make one if it is not exist yet. Make template file name if translator is nil" "self new dirNameCategory: 'Morphic-Scripting Support' translator: NaturalLanguageTranslator current" "self new dirNameCategory: 'Morphic-Scripting Support' translator: nil" | safeCategory fileName dirName pathName | safeCategory := category copyReplaceAll: ' ' with: ':='. fileName := translator ifNil: [safeCategory , '.pot'] ifNotNil: [translator localeID posixName , '.po']. dirName := (safeCategory findTokens: '-') inject: 'po' into: [:aString :next | aString , FileDirectory slash , next]. pathName := dirName , FileDirectory slash , fileName. (FileDirectory default directoryNamed: dirName) assureExistence. ^ pathName! ----- Method: GetTextExporter>>dirNameDomain:translator: (in category 'exporting') ----- dirNameDomain: domain translator: translator "Answer a file name for the domain. Make one if it is not exist yet. Make template file name if translator is nil" "self new dirNameDomain: 'etoys' translator: NaturalLanguageTranslator current" "self new dirNameDomain: 'etoys' translator: nil" | fileName dirName pathName | "safeCategory := category copyReplaceAll: ' ' with: ':='." fileName := domain, (translator ifNil: ['.pot'] ifNotNil: ['.po']). dirName := 'po', FileDirectory slash, (translator ifNil: ['templates'] ifNotNil: [translator localeID posixName]). pathName := dirName , FileDirectory slash , fileName. (FileDirectory default directoryNamed: dirName) assureExistence. ^ pathName! ----- Method: GetTextExporter>>export:translator:domain: (in category 'private') ----- export: literals translator: translator domain: domainName | fileName | "Export a gettext file in a category. literals is a dictionary of keyword -> #(MethodReference...) in the textDomain." fileName := self dirNameDomain: domainName translator: translator. [stream := FileStream forceNewFileNamed: fileName. stream lineEndConvention: #lf. stream converter: UTF8TextConverter new. self exportHeader: domainName. domainName = TextDomainManager defaultDomain ifTrue: [self exportInformation: self createExtraInformation]. self exportBody: literals translator: translator] ensure: [stream close]! ----- Method: GetTextExporter>>exportBody:translator: (in category 'file out') ----- exportBody: literals translator: translator "Export a gettext file body. literals is a dictionary of keyword -> #(MethodReference...) in the textDomain." "Build {sortKey. comment. msgid } to optimize sorting (getting category is too slow). If there are two or more methods for a mgsid, only first method (alphabetical) is used for sorting." | sorted msgid sortedMethods category sortKey comment triplets commentUnderLined | triplets := literals associations collect: [:assoc | msgid := assoc key. sortedMethods := assoc value asArray sort. category := (Smalltalk at: sortedMethods first classSymbol) category asString. sortKey := category , ',' , sortedMethods first printString , ',' , msgid. comment := (sortedMethods collect: [:each | each actualClass asString , '>>' , each methodSymbol asString]) inject: category into: [:result :methodName | result , ',' , methodName]. "Replace white spaces to := because gettext tool might replace a space to a new line some times, and it makes difficult to take a diff." commentUnderLined := comment copyReplaceAll: ' ' with: ':='. Array with: sortKey with: commentUnderLined with: msgid]. "Sort and output the words" sorted := triplets sort: [:a :b | a first <= b first]. sorted do: [:triplet | comment := triplet second. msgid := triplet third. self exportRecordHeader: comment. self exportPhrase: msgid translation: (self translationFor: msgid in: translator)]! ----- Method: GetTextExporter>>exportHeader (in category 'private-headers') ----- exportHeader self exportTag: 'msgid' msg: ''. self exportTag: 'msgstr' msg: ''. self createHeaders do: [:each | self exportHeaderLineKey: each key value: each value]. stream cr; cr! ----- Method: GetTextExporter>>exportHeader: (in category 'private') ----- exportHeader: domainName | headers | self exportTag: 'msgid' msg: ''. self exportTag: 'msgstr' msg: ''. headers := self createHeaders. headers add: 'X-Etoys-Domain' -> domainName. headers do: [:each | self exportHeaderLineKey: each key value: each value]. stream cr; cr! ----- Method: GetTextExporter>>exportHeaderLineKey:value: (in category 'private') ----- exportHeaderLineKey: keyString value: valueString stream nextPut: $"; nextPutAll: keyString; nextPut: $:; space; nextPutAll: valueString; nextPutAll: '\n'; nextPut: $"; cr.! ----- Method: GetTextExporter>>exportInformation: (in category 'private') ----- exportInformation: anOrderedCollection anOrderedCollection do: [:each | self exportRecordHeader: each second. self exportPhrase: each third translation: '']. stream cr.! ----- Method: GetTextExporter>>exportPhrase:translation: (in category 'private') ----- exportPhrase: phraseString translation: translationString | normalizedTrans tmp transStartsWithCR transEndsWithCR| phraseString isEmpty ifTrue: [^ self]. self exportTag: 'msgid' msg: phraseString. translationString size = 0 ifTrue: [ normalizedTrans := '' ] ifFalse: [ transEndsWithCR := translationString last = (Character cr). phraseString last = (Character cr) ifTrue: [ transEndsWithCR ifTrue: [ normalizedTrans := translationString ] ifFalse: [ normalizedTrans := translationString , String cr ] ] ifFalse: [ transEndsWithCR ifTrue: [ normalizedTrans := translationString allButLast ] ifFalse: [ normalizedTrans := translationString ] ]. transStartsWithCR := normalizedTrans first = (Character cr). phraseString first = (Character cr) ifTrue: [ transStartsWithCR ifFalse: [ tmp := (Character cr asString) , normalizedTrans. normalizedTrans := tmp. ] ] ifFalse: [ transStartsWithCR ifTrue: [ normalizedTrans := normalizedTrans allButFirst ] ] ]. self exportTag: 'msgstr' msg: normalizedTrans. stream cr! ----- Method: GetTextExporter>>exportRecordHeader: (in category 'private') ----- exportRecordHeader: context stream nextPutAll: '#: '; nextPutAll: context; cr.! ----- Method: GetTextExporter>>exportTag:msg: (in category 'private') ----- exportTag: tag msg: aString stream nextPutAll: tag. stream space. aString lineIndicesDo: [:start :endWithoutDelimiters :end | | line | line := (end = endWithoutDelimiters) ifTrue: [aString copyFrom: start to: endWithoutDelimiters] ifFalse: [(aString at: endWithoutDelimiters + 1) = Character cr ifTrue: [aString copyFrom: start to: endWithoutDelimiters + 1] ifFalse: [(aString copyFrom: start to: endWithoutDelimiters) copyWith: Character cr]]. stream nextPut: $"; nextPutAll: (self formatString: line); nextPut: $"; cr].! ----- Method: GetTextExporter>>exportTemplate (in category 'exporting') ----- exportTemplate "GetTextExporter2 new exportTemplate" self exportTranslator: nil! ----- Method: GetTextExporter>>exportTranslator: (in category 'exporting') ----- exportTranslator: translator "Export translation files. the file extention is 'po', or 'pot' if translator is nil " "GetTextExporter2 new exportTranslator: NaturalLanguageTranslator current " | domains | domains := Dictionary new. self appendTranslations: domains. domains keysAndValuesDo: [:domainName :value | self export: value translator: translator domain: domainName]! ----- Method: GetTextExporter>>formatReplacements (in category 'private') ----- formatReplacements | replacements | replacements := OrderedCollection new. replacements add: '\' -> '\\'. replacements add: String cr -> '\n'. replacements add: String tab -> '\t'. replacements add: '"' -> '\"'. ^ replacements! ----- Method: GetTextExporter>>formatString: (in category 'private') ----- formatString: aString | result | result := aString. self formatReplacements do: [:each | result := result copyReplaceAll: each key with: each value]. ^ result! ----- Method: GetTextExporter>>getTextDomainForPackage: (in category 'as yet unclassified') ----- getTextDomainForPackage: aPackageInfo ^TextDomainManager domainForPackage: aPackageInfo! ----- Method: GetTextExporter>>stream (in category 'accessing') ----- stream ^ stream! ----- Method: GetTextExporter>>stream: (in category 'accessing') ----- stream: aStream stream := aStream! ----- Method: GetTextExporter>>translationFor:in: (in category 'private') ----- translationFor: aKey in: translator | translation | translator ifNil: [^ '']. TextDomainManager allKnownDomains do: [:domain | translation := translator translate: aKey inDomain: domain. aKey = translation ifFalse: [^translation] ]. ^ aKey! Object subclass: #GetTextInterchange instanceVariableNames: 'language stream' classVariableNames: '' poolDictionaries: '' category: 'GetText-Editor'! GetTextInterchange subclass: #GetTextImporter instanceVariableNames: 'msgId msgStr state' classVariableNames: '' poolDictionaries: '' category: 'GetText-Editor'! !GetTextImporter commentStamp: 'tak 10/24/2007 11:23' prior: 0! GetTextImporter load gettext po file into a InternalTranslator. GetTextImporter new importID: (LocaleID isoString: 'lang-name') fileNamed: 'lang.po' ! ----- Method: GetTextImporter class>>cleanUpUnnecessaryPhrases (in category 'utilities') ----- cleanUpUnnecessaryPhrases | keys refuse replaceBlock reader writer char result | "GetTextImporter cleanUpUnnecessaryPhrases" "" "Collect wrong phrases" keys := InternalTranslator allKnownPhrases copy keys. refuse := Set new. "replaceBlock value: 'te\\nst'." replaceBlock := [:aString | reader := aString readStream. writer := '' writeStream. [reader atEnd] whileFalse: [char := reader next. (char = $\ and: [reader peek = $\]) ifFalse: [writer nextPut: char]]. writer contents]. keys do: [:each | result := replaceBlock value: each. (result ~= each and: [keys includes: result]) ifTrue: [refuse add: each]. result := GetTextImporter new formatString: each. (result ~= each and: [keys includes: result]) ifTrue: [refuse add: each]]. "" "Remove from translated" InternalTranslator cachedTranslations do: [:each | refuse do: [:key | each translations removeKey: key ifAbsent: []]]. "" "Remove from untranslated" refuse do: [:key | InternalTranslator allKnownPhrases removeKey: key ifAbsent: []]! ----- Method: GetTextImporter class>>import:allDirectory: (in category 'utilities') ----- import: translator allDirectory: aFileDirectory "self import: NaturalLanguageTranslator current allDirectory: FileDirectory default" | fileName targetFile | fileName := translator localeID posixName , '.po'. (FileDirectory default directoryNamed: 'po') withAllSubdirectoriesCollect: [:each | (each fileExists: fileName) ifTrue: [targetFile := each fullNameFor: fileName. self new import: translator fileNamed: targetFile]]! ----- Method: GetTextImporter class>>importAll (in category 'utilities') ----- importAll "GetTextImporter importAll" "Import all gettext files on po/. Only registered language is imported" InternalTranslator cachedTranslations do: [:translator | self import: translator allDirectory: FileDirectory default]! ----- Method: GetTextImporter>>appendId: (in category 'parsing') ----- appendId: aString msgId := msgId , aString! ----- Method: GetTextImporter>>appendStr: (in category 'parsing') ----- appendStr: aString msgStr := msgStr , aString! ----- Method: GetTextImporter>>formatString: (in category 'private') ----- formatString: aString " self assert: (GetTextImporter new formatString: 'test') = 'test'. self assert: (GetTextImporter new formatString: 'te\nst') = ('te', String cr, 'st'). self assert: (GetTextImporter new formatString: 'te\\nst') = ('te\nst'). self assert: (GetTextImporter new formatString: 'te\\st') = ('te\st'). self assert: (GetTextImporter new formatString: 'te\st') = ('te\st'). " | reader writer char | reader := aString readStream. writer := '' writeStream. [reader atEnd] whileFalse: [char := reader next. (char = $\ and: [reader atEnd not]) ifTrue: [char := reader next. char caseOf: { [$n] -> [writer nextPut: Character cr]. [$t] -> [writer nextPut: Character tab]. [$"] -> [writer nextPut: $"]. [$\] -> [writer nextPut: $\]} otherwise: [writer nextPutAll: {$\. char}]] ifFalse: [writer nextPut: char]]. ^ writer contents! ----- Method: GetTextImporter>>import: (in category 'importing') ----- import: aLanguage ^ self import: aLanguage fileNamed: aLanguage localeID posixName , '.po'! ----- Method: GetTextImporter>>import:fileNamed: (in category 'importing') ----- import: aLanguage fileNamed: fileName self importID: aLanguage localeID fileNamed: fileName! ----- Method: GetTextImporter>>importID:fileNamed: (in category 'importing') ----- importID: localeID fileNamed: fileName | currentPlatform | language := InternalTranslator newLocaleID: localeID. currentPlatform := Locale currentPlatform. [Locale currentPlatform: (Locale localeID: localeID). [stream := FileStream readOnlyFileNamed: fileName. stream text. self parse] ensure: [stream notNil ifTrue: [stream close]]] ensure: [Locale currentPlatform: currentPlatform]. NaturalLanguageTranslator privateStartUp "Actually it is not private no more...".! ----- Method: GetTextImporter>>initialize (in category 'initialize-release') ----- initialize msgId := ''. msgStr := ''. state := nil! ----- Method: GetTextImporter>>parse (in category 'parsing') ----- parse | size | size := (stream isKindOf: FileStream) ifTrue: [stream size] ifFalse: [1]. ProgressInitiationException display: 'Importing phrases from a gettext file.' during: [:bar | [stream atEnd] whileFalse: [| line | line := stream upTo: Character linefeed. self parseLine: ((line endsWith: String cr) ifTrue: [line allButLast] ifFalse: [line]). bar value: stream position / size]]. self storeTranslation! ----- Method: GetTextImporter>>parseLine: (in category 'parsing') ----- parseLine: lineString (lineString beginsWith: '"Content-Type:') ifTrue: [self setContentType: lineString. ^ self]. (lineString beginsWith: '#') ifTrue: ["do nothing" ^ self]. lineString = '' ifTrue: [^ self storeTranslation]. (lineString beginsWith: 'msgid') ifTrue: [state := #appendId:. self parseMsg: lineString. ^ self]. (lineString beginsWith: 'msgstr') ifTrue: [state := #appendStr:. self parseMsg: lineString. ^ self]. self parseMsg: lineString! ----- Method: GetTextImporter>>parseMsg: (in category 'parsing') ----- parseMsg: lineString | begin end msg | begin := lineString indexOf: $". end := lineString lastIndexOf: $". msg := begin + 1 <= (end - 1) ifTrue: [lineString copyFrom: begin + 1 to: end - 1] ifFalse: ['']. state ifNotNil: [self perform: state with: msg]. ^ msg! ----- Method: GetTextImporter>>setContentType: (in category 'parsing') ----- setContentType: lineString "self new setContentType: 'Content-Type: text/plain; charset=utf-8'" | reader charSet | reader := lineString readStream. reader upTo: $=. charSet := reader upTo: $\. stream converter: (TextConverter newForEncoding: charSet)! ----- Method: GetTextImporter>>storeTranslation (in category 'parsing') ----- storeTranslation | key | key := self formatString: msgId. msgId isEmpty ifFalse: [InternalTranslator registerPhrase: key. msgStr isEmpty ifFalse: [language rawPhrase: key translation: (self formatString: msgStr)]]. self initialize! ----- Method: GetTextInterchange>>defaultFileName (in category 'private') ----- defaultFileName ^ language localeID posixName , '.po'! ----- Method: GetTextInterchange>>language: (in category 'accessing') ----- language: translator language := translator! ----- Method: GetTextInterchange>>stream (in category 'accessing') ----- stream ^ stream! ----- Method: GetTextInterchange>>stream: (in category 'accessing') ----- stream: aStream stream := aStream! SystemWindow subclass: #LanguageEditor instanceVariableNames: 'translator translations untranslated selectedTranslation selectedTranslations selectedUntranslated translationsList untranslatedList translationText translationsFilter untranslatedFilter newerKeys' classVariableNames: 'CheckMethods' poolDictionaries: '' category: 'GetText-Editor'! !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 ! ----- Method: LanguageEditor class>>checkMethods (in category 'private') ----- checkMethods ^CheckMethods ifNil: [CheckMethods := self initCheckMethods]! ----- Method: LanguageEditor class>>ensureVisibilityOfWindow: (in category 'private') ----- 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! ----- Method: LanguageEditor class>>initCheckMethods (in category 'initialize-release') ----- initCheckMethods "LanguageEditor initCheckMethods" | registry | registry := Dictionary new. registry at: 'es' put: #checkSpanishPhrase:translation:; yourself. ^registry! ----- Method: LanguageEditor class>>initialize (in category 'initialize-release') ----- initialize "initialize the receiver" "(TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ TheWorldMenu registerOpenCommand: {'Language Editor' translated. {self. #openOnDefault}}. TheWorldMenu registerOpenCommand: {'Language Editor for...' translated. {self. #open}}]"! ----- Method: LanguageEditor class>>on: (in category 'instance creation') ----- on: localeID "answer an instance of the receiver on aLanguage" ^ self new initializeOn: (InternalTranslator cachedTranslations at: localeID ifAbsent: [self inform: ('Translator for {1} is not found' translated format: {localeID}). ^nil])! ----- Method: LanguageEditor class>>open (in category 'opening') ----- open "open the receiver on any language" " LanguageEditor open. " | menu availableLanguages | menu := MenuMorph new defaultTarget: self. menu addTitle: 'Language Editor for...' translated. "" availableLanguages := (InternalTranslator availableLanguageLocaleIDs asSortedCollection: [:x :y | x asString <= y asString]). availableLanguages ifEmpty:[^self inform:'InternalTranslator not initialized']. availableLanguages do: [:eachLanguage | "" menu add: eachLanguage name target: self selector: #openOn: argument: eachLanguage]. "" menu popUpInWorld! ----- Method: LanguageEditor class>>openOn: (in category 'instance creation') ----- openOn: aLanguage "open an instance on aLanguage" | editor | World submorphs do: [:each | "" ((each isKindOf: LanguageEditor) and: [each translator == aLanguage]) ifTrue: ["" self ensureVisibilityOfWindow: each. ^ self]]. "" editor := self on: aLanguage. editor ifNotNil:[^editor openInWorld]! ----- Method: LanguageEditor class>>openOnDefault (in category 'opening') ----- openOnDefault "open the receiver on the default language" self openOn: LocaleID current! ----- Method: LanguageEditor class>>unload (in category 'initialize-release') ----- unload "the receiver is being unloaded" (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: ["" TheWorldMenu unregisterOpenCommand: 'Language Editor'. TheWorldMenu unregisterOpenCommand: 'Language Editor for...'] ! ----- Method: LanguageEditor>>addTranslation (in category 'gui methods') ----- addTranslation "translate a phrase" | phrase | phrase := UIManager default request: 'enter the original:' translated initialAnswer: ''. (phrase isNil or: [phrase = '']) ifTrue: [ self beep. ^ self]. self translatePhrase: phrase! ----- Method: LanguageEditor>>applyTranslations (in category 'gui methods') ----- applyTranslations "private - try to apply the translations as much as possible all over the image" Project current updateLocaleDependents! ----- Method: LanguageEditor>>asHtml: (in category 'reporting') ----- asHtml: aString | stream | stream := String new writeStream. aString do: [:each | each caseOf: { [Character cr] -> [stream nextPutAll: '
']. [$&] -> [stream nextPutAll: '&']. [$<] -> [stream nextPutAll: '<']. [$>] -> [stream nextPutAll: '>']. [$*] -> [stream nextPutAll: '☆']. [$@] -> [stream nextPutAll: '&at;']} otherwise: [stream nextPut: each]]. ^ stream contents! ----- Method: LanguageEditor>>browseMethodsWithTranslation (in category 'gui methods') ----- 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! ----- Method: LanguageEditor>>browseMethodsWithUntranslated (in category 'gui methods') ----- browseMethodsWithUntranslated | untrans | self selectedUntranslated isZero ifTrue: ["" self beep. self inform: 'select the untrans phrase to look for' translated. ^ self]. "" untrans := self untranslated at: self selectedUntranslated. SystemNavigation default browseMethodsWithLiteral: untrans. ! ----- Method: LanguageEditor>>check (in category 'private') ----- check "check the translations and answer a collection with the results" | results counter phrasesCount checkMethod | results := OrderedCollection new. untranslated := self untranslated. phrasesCount := self translations size + self untranslated size. counter := 0. checkMethod := self class checkMethods at: self translator localeID printString ifAbsent: [^results]. self 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 printShowingMaxDecimalPlaces: 2. Transcript show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent}); cr]]. self 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 printShowingMaxDecimalPlaces: 2. Transcript show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent}); cr]]. ^ results! ----- Method: LanguageEditor>>checkPhrase:translation: (in category 'private') ----- checkPhrase: phraseString translation: translationString ^nil! ----- Method: LanguageEditor>>checkSpanishPhrase:translation: (in category 'private') ----- checkSpanishPhrase: phraseString translation: translationString "check the translation and 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 includes: $?) and: [(translationString includes: $ø) not]) ifTrue: [^ 'øOlvidÛ el signo de pregunta?']. ((translationString includes: $!!) and: [(translationString includes: $°) not]) ifTrue: [^ 'øOlvidÛ el signo de admiraciÛn?']. " ^ nil ! ----- Method: LanguageEditor>>checkUntranslatedPhrase: (in category 'private') ----- 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! ----- Method: LanguageEditor>>codeSelectedTranslation (in category 'gui methods') ----- codeSelectedTranslation | keys code | keys := selectedTranslations collect: [:key | self translations at: key]. code := String streamContents: [:aStream | self translator fileOutOn: aStream keys: keys withBOM: false]. (StringHolder new contents: code) openLabel: 'exported codes' translated! ----- Method: LanguageEditor>>codeSelectedTranslationAsMimeString (in category 'gui methods') ----- codeSelectedTranslationAsMimeString | keys code cont | keys := selectedTranslations collect: [:key | self translations at: key]. code := String streamContents: [:aStream | self translator fileOutOn: aStream keys: keys withBOM: false]. cont := String streamContents: [:strm | strm nextPutAll: '"UTF8+Gzip+Base64 encoded translation for;'; cr. strm nextPutAll: '#('. keys do: [:each | strm nextPutAll: '''', each, ''' '.]. strm nextPutAll: ')"'; cr; cr. strm nextPutAll: 'NaturalLanguageTranslator loadForLocaleIsoString: '. strm nextPut: $'. strm nextPutAll: translator localeID isoString. strm nextPut: $'. strm nextPutAll: ' fromGzippedMimeLiteral: '. strm nextPut: $'. strm nextPutAll: code squeakToUtf8 asByteArray zipped base64Encoded. strm nextPutAll: '''.'. strm cr. ]. (StringHolder new contents: cont) openLabel: 'exported codes in UTF8+Gzip+Base64 encoding' translated! ----- Method: LanguageEditor>>createButtonLabel:action:help: (in category 'initialization - toolbar') ----- 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! ----- Method: LanguageEditor>>createMainToolbar (in category 'initialization - toolbar') ----- 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: 'new' action: #newTranslations help: 'Create translations for new language.'). 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' action: #getText help: 'Interface with gettext.'). "" ^ toolbar! ----- Method: LanguageEditor>>createRow (in category 'initialization - toolbar') ----- createRow "create a row" | row | row := AlignmentMorph newRow. row layoutInset: 3; wrapCentering: #center; cellPositioning: #leftCenter. "" ^ row! ----- Method: LanguageEditor>>createStatusbar (in category 'initialization - statusbar') ----- 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! ----- Method: LanguageEditor>>createTranslationsToolbar (in category 'initialization - toolbar') ----- 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! ----- Method: LanguageEditor>>createUntranslatedToolbar (in category 'initialization - toolbar') ----- 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! ----- Method: LanguageEditor>>createUpdatingButtonWording:action:help: (in category 'initialization - toolbar') ----- 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! ----- Method: LanguageEditor>>delete (in category 'open/close') ----- delete "Remove the receiver as a submorph of its owner" self model: nil. super delete ! ----- Method: LanguageEditor>>deselectAllTranslation (in category 'gui methods') ----- deselectAllTranslation selectedTranslations := IdentitySet new. self changed: #allSelections! ----- Method: LanguageEditor>>filterTranslations (in category 'gui methods') ----- filterTranslations | filter | filter := UIManager default request: 'filter with (empty string means no-filtering)' translated initialAnswer: self translationsFilter. self filterTranslations: filter! ----- Method: LanguageEditor>>filterTranslations: (in category 'gui methods') ----- filterTranslations: aString | filter | filter := aString ifNil:['']. "" translationsFilter := filter. self refreshTranslations. ! ----- Method: LanguageEditor>>filterUntranslated (in category 'gui methods') ----- filterUntranslated | filter | filter := UIManager default request: 'filter with (empty string means no-filtering)' translated initialAnswer: self untranslatedFilter. self filterUntranslated: filter! ----- Method: LanguageEditor>>filterUntranslated: (in category 'gui methods') ----- filterUntranslated: aString | filter | filter := aString ifNil: ['']. "" untranslatedFilter := filter. self refreshUntranslated! ----- Method: LanguageEditor>>getText (in category 'gui methods') ----- getText | menu | menu := MenuMorph new defaultTarget: self. "" menu add: 'gettext template' translated target: self selector: #getTextExportTemplate. menu lastItem setBalloonText: 'exports the translations to gettext separated format.' translated. menu add: 'gettext export' translated target: self selector: #getTextExport. menu lastItem setBalloonText: 'Exports the translations to GetText format.' translated. "" menu add: 'gettext import' translated target: self selector: #getTextImport. menu lastItem setBalloonText: 'Imports the translations from GetText format.' translated. "" menu popUpInWorld! ----- Method: LanguageEditor>>getTextExport (in category 'gui methods') ----- getTextExport Cursor wait showWhile: [GetTextExporter new exportTranslator: self model]! ----- Method: LanguageEditor>>getTextExportTemplate (in category 'gui methods') ----- getTextExportTemplate Cursor wait showWhile: [GetTextExporter new exportTemplate] ! ----- Method: LanguageEditor>>getTextImport (in category 'gui methods') ----- getTextImport | menu | menu := MenuMorph new defaultTarget: self. menu addTitle: 'Choose translation file' translated. menu add: 'All *.po files' translated action: #getTextImportAll. menu add: 'Choose a file' translated action: #getTextImportAFile. menu popUpInWorld! ----- Method: LanguageEditor>>getTextImportAFile (in category 'gui methods') ----- getTextImportAFile | result | result := (StandardFileMenu new pattern: '*.po'; oldFileFrom: (FileDirectory default directoryNamed: 'po')) startUpWithCaption: 'Select a File:' translated. result ifNil: [^ self]. self withUnboundModelDo: [:trans | Cursor wait showWhile: [GetTextImporter new import: trans fileNamed: (result directory fullNameFor: result name)]]! ----- Method: LanguageEditor>>getTextImportAll (in category 'gui methods') ----- getTextImportAll self withUnboundModelDo: [:trans | Cursor wait showWhile: [GetTextImporter import: trans allDirectory: FileDirectory default]]. self refreshBoth! ----- Method: LanguageEditor>>identifyUnusedStrings (in category 'stef') ----- identifyUnusedStrings "self new identifyUnusedStrings" translationsList getList do: [:each | Transcript show: each. Transcript show: (Smalltalk allSelect: [:method | method hasLiteralSuchThat: [:lit | lit isString and: [lit includesSubstring: each caseSensitive: true]]]) size printString; cr]! ----- Method: LanguageEditor>>initializeNewerKeys (in category 'initialization') ----- initializeNewerKeys newerKeys := Set new. ! ----- Method: LanguageEditor>>initializeOn: (in category 'initialization') ----- initializeOn: aLanguage "initialize the receiver on aLanguage" "" selectedTranslation := 0. selectedUntranslated := 0. selectedTranslations := IdentitySet new. "" translator := aLanguage. "" self model: aLanguage. self setLabel: 'Language editor for: ' translated , self translator name. "" self initializeToolbars. self initializePanels. self initializeStatusbar. self initializeNewerKeys. ! ----- Method: LanguageEditor>>initializePanels (in category 'initialization') ----- 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). self hResizing: #shrinkWrap! ----- Method: LanguageEditor>>initializeStatusbar (in category 'initialization - statusbar') ----- initializeStatusbar "initialize the receiver's statusbar" self addMorph: self createStatusbar frame: (0 @ 0.93 corner: 1 @ 1)! ----- Method: LanguageEditor>>initializeToolbars (in category 'initialization - toolbar') ----- 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)! ----- Method: LanguageEditor>>loadFromFile (in category 'gui methods') ----- loadFromFile | fileName | fileName := self selectTranslationFileName. fileName isNil ifTrue: ["" self beep. ^ self]. "" Cursor wait showWhile: [ self translator loadFromFileNamed: fileName. self refreshBoth]! ----- Method: LanguageEditor>>mergeFromFile (in category 'gui methods') ----- mergeFromFile | fileName | fileName := self selectTranslationFileName. fileName isNil ifTrue: ["" self beep. ^ self]. "" Cursor wait showWhile: [ self translator loadFromFileNamed: fileName. self refreshBoth]! ----- Method: LanguageEditor>>newTranslations (in category 'gui methods') ----- newTranslations "private - try to apply the translations as much as possible all over the image" | result newID | result := UIManager default request: 'New locale ID string?' translated initialAnswer: Locale current determineLocaleID isoString. result isEmpty ifTrue: ["Do nothing" ^ self]. newID := LocaleID isoString: result. InternalTranslator newLocaleID: (LocaleID isoString: result). self class openOn: newID! ----- Method: LanguageEditor>>numberOfTimesStringIsUsed: (in category 'stef') ----- numberOfTimesStringIsUsed: aString ^ (self systemNavigation allSelect: [:method | method hasLiteralSuchThat: [:lit | lit isString and: [lit includesSubstring: aString caseSensitive: true]]]) size! ----- Method: LanguageEditor>>okToChange (in category 'updating') ----- 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]! ----- Method: LanguageEditor>>perform:orSendTo: (in category 'message handling') ----- perform: selector orSendTo: otherTarget "I wish to intercept and handle selector myself" ^ self perform: selector! ----- Method: LanguageEditor>>phrase:translation: (in category 'gui methods') ----- phrase: phraseString translation: translationString "set the models's translation for phraseString" self translator phrase: phraseString translation: translationString. self refreshBoth. newerKeys add: phraseString. ! ----- Method: LanguageEditor>>phraseToTranslate (in category 'gui methods') ----- phraseToTranslate "answer a phrase to translate. use the selected untranslated phrase or ask for a new one" ^ self selectedUntranslated isZero ifTrue: [UIManager default multiLineRequest: 'new phrase to translate' translated centerAt: Sensor cursorPoint initialAnswer: '' answerHeight: 200] ifFalse: [self untranslated at: self selectedUntranslated]! ----- Method: LanguageEditor>>printHeaderReportOn: (in category 'reporting') ----- 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! ----- Method: LanguageEditor>>printReportOn: (in category 'reporting') ----- printReportOn: aStream "append to aStream a report of the receiver with swiki format" self printHeaderReportOn: aStream. self printUntranslatedReportOn: aStream. self printTranslationsReportOn: aStream! ----- Method: LanguageEditor>>printTranslationsReportOn: (in category 'reporting') ----- 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 translate: each)}); cr]. aStream cr; cr! ----- Method: LanguageEditor>>printUntranslatedReportOn: (in category 'reporting') ----- 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! ----- Method: LanguageEditor>>refreshBoth (in category 'updating') ----- refreshBoth self refreshUntranslated ! ----- Method: LanguageEditor>>refreshTranslations (in category 'updating') ----- refreshTranslations "refresh the translations panel" self selectedTranslation: 0. translations := nil. self changed: #translations. ! ----- Method: LanguageEditor>>refreshUntranslated (in category 'updating') ----- refreshUntranslated "refresh the untranslated panel" self refreshTranslations. self selectedUntranslated: 0. untranslated := nil. self changed: #untranslated. ! ----- Method: LanguageEditor>>removeTranslatedButUnusedStrings (in category 'stef') ----- 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]]! ----- Method: LanguageEditor>>removeTranslation (in category 'gui methods') ----- 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 refreshBoth! ----- Method: LanguageEditor>>removeUntranslated (in category 'gui methods') ----- removeUntranslated "remove the selected untranslated phrase" | untrans | self selectedUntranslated isZero ifTrue: ["" self beep. self inform: 'select the untranslated phrase to remove' translated. ^ self]. "" untrans := self untranslated at: self selectedUntranslated. "" (self confirm: ('Removing "{1}". Are you sure you want to do this?' translated format: {untrans})) ifFalse: [^ self]. "" self translator removeUntranslated: untrans! ----- Method: LanguageEditor>>removeUntranslatedButUnusedStrings (in category 'stef') ----- 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 refreshUntranslated. ! ----- Method: LanguageEditor>>report (in category 'gui methods') ----- report self reportString openInWorkspaceWithTitle: 'report' translated! ----- Method: LanguageEditor>>reportString (in category 'reporting') ----- reportString "answer a string with a report of the receiver" | stream | stream := String new writeStream. self printReportOn: stream. ^ stream contents! ----- Method: LanguageEditor>>resetNewerKeys (in category 'gui methods') ----- resetNewerKeys self initializeNewerKeys. ! ----- Method: LanguageEditor>>saveToFile (in category 'gui methods') ----- saveToFile "save the translator to a file" | fileName | fileName := UIManager default 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]! ----- Method: LanguageEditor>>searchTranslation (in category 'gui methods') ----- searchTranslation | search | search := UIManager default request: 'search for' translated initialAnswer: ''. (search isNil or: [search isEmpty]) ifTrue: [ self beep. ^ self]. self searchTranslation: search! ----- Method: LanguageEditor>>searchTranslation: (in category 'gui methods') ----- searchTranslation: aString | results index | results := self translations select: [:each | "" ('*' , aString , '*' match: each) or: ['*' , aString , '*' match: (self translator translate: 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 translate: each) copy replaceAll: Character cr with: $\)])) startUpWithCaption: 'select the translation...' translated. "" index isZero ifTrue: ["" self beep. ^ self]. "" self selectTranslationPhrase: (results at: index)! ----- Method: LanguageEditor>>searchUntranslated (in category 'gui methods') ----- searchUntranslated | search | search := UIManager default request: 'search for' translated initialAnswer: ''. (search isNil or: [search isEmpty]) ifTrue: [ self beep. ^ self]. self searchUntranslated: search! ----- Method: LanguageEditor>>searchUntranslated: (in category 'gui methods') ----- 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)! ----- Method: LanguageEditor>>selectAllTranslation (in category 'gui methods') ----- selectAllTranslation selectedTranslations := (1 to: self translations size) asIdentitySet. self changed: #allSelections! ----- Method: LanguageEditor>>selectNewerKeys (in category 'gui methods') ----- selectNewerKeys | index | self deselectAllTranslation. newerKeys do: [:k | index := self translations indexOf: k ifAbsent: [0]. index > 0 ifTrue: [ self selectedTranslationsAt: index put: true ]. ]. ! ----- Method: LanguageEditor>>selectTranslationFileName (in category 'gui methods') ----- 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]! ----- Method: LanguageEditor>>selectTranslationPhrase: (in category 'gui methods') ----- selectTranslationPhrase: phraseString self selectedTranslation: (self translations indexOf: phraseString)! ----- Method: LanguageEditor>>selectUntranslatedPhrase: (in category 'gui methods') ----- selectUntranslatedPhrase: phraseString self selectedUntranslated: (self untranslated indexOf: phraseString)! ----- Method: LanguageEditor>>selectedTranslation (in category 'accessing') ----- selectedTranslation "answer the selectedTranslation" ^ selectedTranslation! ----- Method: LanguageEditor>>selectedTranslation: (in category 'accessing') ----- selectedTranslation: anInteger "change the receiver's selectedTranslation" selectedTranslation := anInteger. "" self changed: #selectedTranslation. self changed: #translation! ----- Method: LanguageEditor>>selectedTranslationsAt: (in category 'accessing') ----- selectedTranslationsAt: index ^ selectedTranslations includes: index! ----- Method: LanguageEditor>>selectedTranslationsAt:put: (in category 'accessing') ----- selectedTranslationsAt: index put: value value = true ifTrue: [selectedTranslations add: index] ifFalse: [selectedTranslations remove: index ifAbsent: []]! ----- Method: LanguageEditor>>selectedUntranslated (in category 'accessing') ----- selectedUntranslated "answer the selectedUntranslated" ^ selectedUntranslated! ----- Method: LanguageEditor>>selectedUntranslated: (in category 'accessing') ----- selectedUntranslated: anInteger "change the selectedUntranslated" selectedUntranslated := anInteger. "" self changed: #selectedUntranslated! ----- Method: LanguageEditor>>status (in category 'gui methods') ----- 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}! ----- Method: LanguageEditor>>translate (in category 'gui methods') ----- translate "translate a phrase" | phrase | phrase := self phraseToTranslate. "" (phrase isNil or: [phrase = '']) ifTrue: ["" self beep. ^ self]. "" self translatePhrase: phrase. self refreshBoth! ----- Method: LanguageEditor>>translatePhrase: (in category 'gui methods') ----- translatePhrase: aString "translate aString" | translation | translation := UIManager default 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! ----- Method: LanguageEditor>>translation (in category 'accessing') ----- translation "answer the translation for the selected phrase" self selectedTranslation isZero ifTrue: [^ '