• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
1# Copyright 2001, 2002 Dave Abrahams
2# Copyright 2002, 2003, 2004, 2005 Vladimir Prus
3# Copyright 2008 Jurko Gospodnetic
4# Distributed under the Boost Software License, Version 1.0.
5# (See accompanying file LICENSE_1_0.txt or http://www.boost.org/LICENSE_1_0.txt)
6
7import "class" : is-instance ;
8
9
10# For all elements of 'list' which do not already have 'suffix', add 'suffix'.
11#
12rule apply-default-suffix ( suffix : list * )
13{
14    local result ;
15    for local i in $(list)
16    {
17        if $(i:S) = $(suffix)
18        {
19            result += $(i) ;
20        }
21        else
22        {
23            result += $(i)$(suffix) ;
24        }
25    }
26    return $(result) ;
27}
28
29
30# If 'name' contains a dot, returns the part before the last dot. If 'name'
31# contains no dot, returns it unmodified.
32#
33rule basename ( name )
34{
35    if $(name:S)
36    {
37        name = $(name:B) ;
38    }
39    return $(name) ;
40}
41
42
43# Return the file of the caller of the rule that called caller-file.
44#
45rule caller-file ( )
46{
47    local bt = [ BACKTRACE ] ;
48    return $(bt[9]) ;
49}
50
51
52# Tests if 'a' is equal to 'b'. If 'a' is a class instance, calls its 'equal'
53# method. Uses ordinary jam's comparison otherwise.
54#
55rule equal ( a b )
56{
57    if [ is-instance $(a) ]
58    {
59        return [ $(a).equal $(b) ] ;
60    }
61    else
62    {
63        if $(a) = $(b)
64        {
65            return true ;
66        }
67    }
68}
69
70
71# Tests if 'a' is less than 'b'. If 'a' is a class instance, calls its 'less'
72# method. Uses ordinary jam's comparison otherwise.
73#
74rule less ( a b )
75{
76    if [ is-instance $(a) ]
77    {
78        return [ $(a).less $(b) ] ;
79    }
80    else
81    {
82        if $(a) < $(b)
83        {
84            return true ;
85        }
86    }
87}
88
89
90# Returns the textual representation of argument. If it is a class instance,
91# class its 'str' method. Otherwise, returns the argument.
92#
93rule str ( value )
94{
95    if [ is-instance $(value) ]
96    {
97        return [ $(value).str ] ;
98    }
99    else
100    {
101        return $(value) ;
102    }
103}
104
105
106# Accepts a list of gristed values and returns them ungristed. Reports an error
107# in case any of the passed parameters is not gristed, i.e. surrounded in angle
108# brackets < and >.
109#
110rule ungrist ( names * )
111{
112    local result ;
113    for local name in $(names)
114    {
115        local stripped = [ MATCH ^<(.*)>$ : $(name) ] ;
116        if ! $(stripped)-defined
117        {
118            import errors ;
119            local quoted-names = \"$(names)\" ;
120            errors.error "in" ungrist "$(quoted-names:J= ):" \"$(name)\" is not
121                of the form <.*> ;
122        }
123        result += $(stripped) ;
124    }
125    return $(result) ;
126}
127
128
129# If the passed value is quoted, unquotes it. Otherwise returns the value
130# unchanged.
131#
132rule unquote ( value ? )
133{
134    local match-result = [ MATCH ^(\")(.*)(\")$ : $(value) ] ;
135    if $(match-result)
136    {
137        return $(match-result[2]) ;
138    }
139    else
140    {
141        return $(value) ;
142    }
143}
144
145
146rule __test__ ( )
147{
148    import assert ;
149    import "class" : new ;
150    import errors : try catch ;
151
152    assert.result 123 : str 123 ;
153
154    class test-class__
155    {
156        rule __init__ (   ) {                            }
157        rule str      (   ) { return "str-test-class"  ; }
158        rule less     ( a ) { return "yes, of course!" ; }
159        rule equal    ( a ) { return "not sure"        ; }
160    }
161
162    assert.result "str-test-class" : str [ new test-class__ ] ;
163    assert.true less 1 2 ;
164    assert.false less 2 1 ;
165    assert.result "yes, of course!" : less [ new test-class__ ] 1 ;
166    assert.true equal 1 1 ;
167    assert.false equal 1 2 ;
168    assert.result "not sure" : equal [ new test-class__ ] 1 ;
169
170    assert.result foo.lib foo.lib : apply-default-suffix .lib : foo.lib foo.lib
171        ;
172
173    assert.result foo : basename foo ;
174    assert.result foo : basename foo.so ;
175    assert.result foo.so : basename foo.so.1 ;
176
177    assert.result         : unquote ;
178    assert.result ""      : unquote "" ;
179    assert.result ""      : unquote \"\" ;
180    assert.result \"      : unquote \"\"\" ;
181    assert.result \"\"    : unquote \"\"\"\" ;
182    assert.result foo     : unquote foo ;
183    assert.result \"foo   : unquote \"foo ;
184    assert.result foo\"   : unquote foo\" ;
185    assert.result foo     : unquote \"foo\" ;
186    assert.result \"foo\" : unquote \"\"foo\"\" ;
187
188    assert.result         : ungrist ;
189    assert.result ""      : ungrist <> ;
190    assert.result foo     : ungrist <foo> ;
191    assert.result <foo>   : ungrist <<foo>> ;
192    assert.result foo bar : ungrist <foo> <bar> ;
193
194    try ;
195    {
196        ungrist "" ;
197    }
198    catch "in" ungrist "\"\":" \"\" is not of the form <.*> ;
199
200    try ;
201    {
202        ungrist foo ;
203    }
204    catch "in" ungrist "\"foo\":" \"foo\" is not of the form <.*> ;
205
206    try ;
207    {
208        ungrist <foo ;
209    }
210    catch "in" ungrist "\"<foo\":" \"<foo\" is not of the form <.*> ;
211
212    try ;
213    {
214        ungrist foo> ;
215    }
216    catch "in" ungrist "\"foo>\":" \"foo>\" is not of the form <.*> ;
217
218    try ;
219    {
220        ungrist foo bar ;
221    }
222    catch "in" ungrist "\"foo\" "\"bar\"":" \"foo\" is not of the form <.*> ;
223
224    try ;
225    {
226        ungrist foo <bar> ;
227    }
228    catch "in" ungrist "\"foo\" "\"<bar>\"":" \"foo\" is not of the form <.*> ;
229
230    try ;
231    {
232        ungrist <foo> bar ;
233    }
234    catch "in" ungrist "\"<foo>\" "\"bar\"":" \"bar\" is not of the form <.*> ;
235}
236