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: