Filename | /var/www/foswikidev/core/lib/Foswiki/Address.pm |
Statements | Executed 30 statements in 5.66ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 14µs | 18µs | BEGIN@64 | Foswiki::Address::
1 | 1 | 1 | 12µs | 24µs | BEGIN@63 | Foswiki::Address::
1 | 1 | 1 | 9µs | 31µs | BEGIN@66 | Foswiki::Address::
1 | 1 | 1 | 8µs | 32µs | BEGIN@72 | Foswiki::Address::
1 | 1 | 1 | 8µs | 34µs | BEGIN@76 | Foswiki::Address::
1 | 1 | 1 | 8µs | 36µs | BEGIN@71 | Foswiki::Address::
1 | 1 | 1 | 8µs | 31µs | BEGIN@74 | Foswiki::Address::
1 | 1 | 1 | 8µs | 32µs | BEGIN@75 | Foswiki::Address::
1 | 1 | 1 | 7µs | 30µs | BEGIN@73 | Foswiki::Address::
1 | 1 | 1 | 4µs | 4µs | BEGIN@78 | Foswiki::Address::
1 | 1 | 1 | 4µs | 4µs | BEGIN@68 | Foswiki::Address::
1 | 1 | 1 | 3µs | 3µs | BEGIN@67 | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _atomiseAsAttachment | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _atomiseAsRoot | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _atomiseAsTOM | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _atomiseAsTopic | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _atomiseAsWeb | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _eq | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _existScore | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _invalidate | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _parse | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _trace_have_valid | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _trace_is_valid | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | _trace_stringify | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | attachment | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | equiv | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | finish | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | isA | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | isValid | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | new | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | rev | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | root | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | stringify | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | tompath | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | topic | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | type | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | web | Foswiki::Address::
0 | 0 | 0 | 0s | 0s | webpath | Foswiki::Address::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # See bottom of file for license and copyright information | ||||
2 | |||||
3 | package Foswiki::Address; | ||||
4 | |||||
5 | =begin TML | ||||
6 | |||||
7 | ---+ package Foswiki::Address | ||||
8 | |||||
9 | This class is used to handle pointers to Foswiki 'resources', which might be | ||||
10 | webs, topics or parts of topics (such as attachments or metadata), optionally | ||||
11 | of a specific revision. | ||||
12 | |||||
13 | The primary goal is to end the tyranny of arbitrary | ||||
14 | =(web, topic, attachment, rev...)= tuples. Users of =Foswiki::Address= should | ||||
15 | be able to enjoy programmatically updating, stringifying, parsing, validating, | ||||
16 | comparing and passing around of _address objects_ that might eventually be | ||||
17 | understood by the wider Foswiki universe, without having to maintain proprietary | ||||
18 | parse/stringify/validate/comparison handling code that must always be | ||||
19 | considerate of the recipient for such tuples. | ||||
20 | |||||
21 | This class does not offer any interaction with resources themselves; rather, | ||||
22 | functionality is provided to create, hold, manipulate, test | ||||
23 | __and de/serialise addresses__ | ||||
24 | |||||
25 | Fundamentally, =Foswiki::Address= can be thought of as an interface to a hash of | ||||
26 | the components necessary to address a specific Foswiki resource. | ||||
27 | |||||
28 | <verbatim> | ||||
29 | my $addr = { | ||||
30 | web => 'Web/SubWeb', | ||||
31 | topic => 'Topic', | ||||
32 | attachment => 'Attachment.pdf', | ||||
33 | rev => 3 | ||||
34 | }; | ||||
35 | </verbatim> | ||||
36 | |||||
37 | <blockquote class="foswikiHelp">%X% __Unresolved issues__ | ||||
38 | * Is this class necessary, or should we make a cleaner, lighter | ||||
39 | =Foswiki::Meta2= - where 'unloaded' objects are no heavier than | ||||
40 | =Foswiki::Address= and provide the same functionality? | ||||
41 | * Should the physical file attachment be treated separately to the metadata | ||||
42 | view of the file attachment(s)? Desirables: | ||||
43 | * ability to unambiguously create pointers to an attachment's data (file) | ||||
44 | * ability for Foswiki core to calculate an http URL for it | ||||
45 | * ability to create pointers to properties (metadata) of the attachment | ||||
46 | * _These questions are slightly loaded in favour of distinguishing | ||||
47 | between the datastream and metadata about the attachment. In an ideal | ||||
48 | world a file attachment would be a first-class citizen to topics: rather | ||||
49 | than topic text, we have the iostream; attachments would have their own | ||||
50 | user metadata, dataforms..._ | ||||
51 | * Duplicating %SYSTEMWEB%.QuerySearch parser functionality. 80% of the code | ||||
52 | in this class is related to parsing "string forms" of addresses of Foswiki | ||||
53 | resources... querysearch parser needs some refactoring so we can delete the | ||||
54 | parser code here. | ||||
55 | * API usability - can we stop passing around (web, topic, attachment, rev) | ||||
56 | tuples - will the =->new()= constructor make sense to plugin authors, core | ||||
57 | hackers? __FEEDBACK WELCOME__, please comment at | ||||
58 | Foswiki:Development.TopicAddressing | ||||
59 | </blockquote> | ||||
60 | |||||
61 | =cut | ||||
62 | |||||
63 | 2 | 24µs | 2 | 36µs | # spent 24µs (12+12) within Foswiki::Address::BEGIN@63 which was called:
# once (12µs+12µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 63 # spent 24µs making 1 call to Foswiki::Address::BEGIN@63
# spent 12µs making 1 call to strict::import |
64 | 2 | 24µs | 2 | 22µs | # spent 18µs (14+4) within Foswiki::Address::BEGIN@64 which was called:
# once (14µs+4µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 64 # spent 18µs making 1 call to Foswiki::Address::BEGIN@64
# spent 4µs making 1 call to warnings::import |
65 | |||||
66 | 2 | 22µs | 2 | 53µs | # spent 31µs (9+22) within Foswiki::Address::BEGIN@66 which was called:
# once (9µs+22µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 66 # spent 31µs making 1 call to Foswiki::Address::BEGIN@66
# spent 22µs making 1 call to Exporter::import |
67 | 2 | 28µs | 1 | 3µs | # spent 3µs within Foswiki::Address::BEGIN@67 which was called:
# once (3µs+0s) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 67 # spent 3µs making 1 call to Foswiki::Address::BEGIN@67 |
68 | 2 | 28µs | 1 | 4µs | # spent 4µs within Foswiki::Address::BEGIN@68 which was called:
# once (4µs+0s) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 68 # spent 4µs making 1 call to Foswiki::Address::BEGIN@68 |
69 | |||||
70 | #use Data::Dumper; | ||||
71 | 2 | 28µs | 2 | 65µs | # spent 36µs (8+28) within Foswiki::Address::BEGIN@71 which was called:
# once (8µs+28µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 71 # spent 36µs making 1 call to Foswiki::Address::BEGIN@71
# spent 28µs making 1 call to constant::import |
72 | 2 | 24µs | 2 | 55µs | # spent 32µs (8+23) within Foswiki::Address::BEGIN@72 which was called:
# once (8µs+23µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 72 # spent 32µs making 1 call to Foswiki::Address::BEGIN@72
# spent 23µs making 1 call to constant::import |
73 | 2 | 26µs | 2 | 53µs | # spent 30µs (7+23) within Foswiki::Address::BEGIN@73 which was called:
# once (7µs+23µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 73 # spent 30µs making 1 call to Foswiki::Address::BEGIN@73
# spent 23µs making 1 call to constant::import |
74 | 2 | 30µs | 2 | 53µs | # spent 31µs (8+23) within Foswiki::Address::BEGIN@74 which was called:
# once (8µs+23µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 74 # spent 31µs making 1 call to Foswiki::Address::BEGIN@74
# spent 23µs making 1 call to constant::import |
75 | 2 | 26µs | 2 | 56µs | # spent 32µs (8+24) within Foswiki::Address::BEGIN@75 which was called:
# once (8µs+24µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 75 # spent 32µs making 1 call to Foswiki::Address::BEGIN@75
# spent 24µs making 1 call to constant::import |
76 | 2 | 45µs | 2 | 60µs | # spent 34µs (8+26) within Foswiki::Address::BEGIN@76 which was called:
# once (8µs+26µs) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 76 # spent 34µs making 1 call to Foswiki::Address::BEGIN@76
# spent 26µs making 1 call to constant::import |
77 | |||||
78 | # spent 4µs within Foswiki::Address::BEGIN@78 which was called:
# once (4µs+0s) by Foswiki::Access::TopicACLAccess::BEGIN@22 at line 83 | ||||
79 | 1 | 5µs | if ( $Foswiki::cfg{UseLocale} ) { | ||
80 | require locale; | ||||
81 | import locale(); | ||||
82 | } | ||||
83 | 1 | 5.29ms | 1 | 4µs | } # spent 4µs making 1 call to Foswiki::Address::BEGIN@78 |
84 | |||||
85 | 1 | 2µs | my $EXISTASLIST_DEFAULT = [qw(attachment topic)]; | ||
86 | 1 | 1µs | my $EXISTAS_DEFAULT = { attachment => 1, topic => 1 }; | ||
87 | 1 | 6µs | my %atomiseAs = ( | ||
88 | root => \&_atomiseAsRoot, | ||||
89 | web => \&_atomiseAsWeb, | ||||
90 | topic => \&_atomiseAsTopic, | ||||
91 | attachment => \&_atomiseAsAttachment, | ||||
92 | META => \&_atomiseAsTOM, | ||||
93 | meta => \&_atomiseAsTOM, | ||||
94 | SECTION => \&_atomiseAsTOM, | ||||
95 | text => \&_atomiseAsTOM, | ||||
96 | '*' => \&_atomiseAsTOM | ||||
97 | ); | ||||
98 | |||||
99 | # The question is: what do we have? The hash is accessed as follows: | ||||
100 | # $pathtypes{ $tompath[0] }->{ scalar(@tompath) } | ||||
101 | 1 | 5µs | my %pathtypes = ( | ||
102 | attachment => { 1 => 'attachments', 2 => 'attachment' }, | ||||
103 | META => { 1 => 'meta', 2 => 'metatype', 3 => 'metamember', 4 => 'metakey' }, | ||||
104 | SECTION => { 1 => 'sections', 2 => 'section' }, | ||||
105 | text => { 1 => 'text' } | ||||
106 | ); | ||||
107 | |||||
108 | # I tried to create a logical parser, but it kept ending up as spaghetti. | ||||
109 | # So we use a lookup table instead... (probably?) easier to follow, faster. | ||||
110 | 1 | 21µs | my %plausibletable = ( | ||
111 | |||||
112 | # root keys represent the path separator signature of the form: | ||||
113 | # combinations of s, S, d, D - where: | ||||
114 | # s = <part>/<part> - sequence of two parts separated by '/' | ||||
115 | # d = <part>.<part> - sequence of two parts separated by '.' | ||||
116 | # S = <part>/<part>/<part>[/]... - sequence > 2 parts separated by '/' | ||||
117 | # D = <part>.<part>.<part>[.]... - sequence > 2 parts separated by '.' | ||||
118 | # | ||||
119 | # sub keys are the type considered; values of the sub keys indicate | ||||
120 | # the plausibility that the given form could be the type indicated: | ||||
121 | # 0/undef - not plausible | ||||
122 | # 1 - plausible without using any context | ||||
123 | # 2 - normal ("unambiguous") form | ||||
124 | # 'webpath' - plausible if given webpath context | ||||
125 | # 'topic' - plausible if given webpath & topic context | ||||
126 | # | ||||
127 | # Foo | ||||
128 | '' => { webpath => 1, topic => 'webpath', attachment => 'topic' }, | ||||
129 | |||||
130 | # Foo.Bar | ||||
131 | 'd' => { webpath => 1, topic => 2, attachment => 'topic' }, | ||||
132 | |||||
133 | # Foo/Bar | ||||
134 | 's' => { webpath => 1, topic => 1, attachment => 'webpath' }, | ||||
135 | |||||
136 | # Foo/Bar.Dog | ||||
137 | 'sd' => { webpath => 0, topic => 2, attachment => 'webpath' }, | ||||
138 | |||||
139 | # Foo.Bar/Dog | ||||
140 | 'ds' => { webpath => 0, topic => 1, attachment => 2 }, | ||||
141 | |||||
142 | # Foo/Bar/Dog | ||||
143 | 'S' => { webpath => 1, topic => 1, attachment => 1 }, | ||||
144 | |||||
145 | # Foo.Bar.Dog | ||||
146 | 'D' => { webpath => 1, topic => 1, attachment => 'topic' }, | ||||
147 | |||||
148 | # Foo.Bar/Cat/Dog | ||||
149 | 'dS' => { webpath => 0, topic => 1, attachment => 1 }, | ||||
150 | |||||
151 | # Foo/Bar.Cat.Dog | ||||
152 | 'sD' => { webpath => 0, topic => 0, attachment => 'webpath' }, | ||||
153 | |||||
154 | # Foo/Bar/Dog.Cat | ||||
155 | 'Sd' => { webpath => 0, topic => 2, attachment => 1 }, | ||||
156 | |||||
157 | # Foo.Bar.Dog/Cat | ||||
158 | 'Ds' => { webpath => 0, topic => 1, attachment => 1 }, | ||||
159 | |||||
160 | # Foo.Bar.Dog/Cat/Bat | ||||
161 | 'DS' => { webpath => 0, topic => 0, attachment => 1 }, | ||||
162 | |||||
163 | # Foo/Bar/Dog.Cat.Bat | ||||
164 | 'SD' => { webpath => 0, topic => 0, attachment => 1 }, | ||||
165 | |||||
166 | # Foo/Bar.Dog/Cat | ||||
167 | 'sds' => { webpath => 0, topic => 0, attachment => 2 }, | ||||
168 | |||||
169 | # Foo/Bar/Dog.Cat/Bat | ||||
170 | 'Sds' => { webpath => 0, topic => 0, attachment => 2 }, | ||||
171 | |||||
172 | # Foo.Bar/Dog.Cat | ||||
173 | 'dsd' => { webpath => 0, topic => 0, attachment => 2 }, | ||||
174 | |||||
175 | # Foo.Bar.Dog/Cat.Bat | ||||
176 | 'Dsd' => { webpath => 0, topic => 0, attachment => 1 }, | ||||
177 | |||||
178 | # Foo.Bar/Dog.Cat.Bat | ||||
179 | 'dsD' => { webpath => 0, topic => 0, attachment => 2 }, | ||||
180 | |||||
181 | # Foo/Bar.Dog/Cat.Bat | ||||
182 | 'sdsd' => { webpath => 0, topic => 0, attachment => 2 }, | ||||
183 | |||||
184 | # Foo/Bar.Dog/Cat.B.a.t | ||||
185 | 'sdsD' => { webpath => 0, topic => 0, attachment => 2 }, | ||||
186 | |||||
187 | # Foo/Bar/Dog.Cat/B.at | ||||
188 | 'Sdsd' => { webpath => 0, topic => 0, attachment => 2 }, | ||||
189 | |||||
190 | # Foo/Bar/Dog.Cat/B.a.t | ||||
191 | 'SdsD' => { webpath => 0, topic => 0, attachment => 2 } | ||||
192 | ); | ||||
193 | 1 | 3µs | my %sepidentchars = | ||
194 | ( 0 => { '.' => 'd', '/' => 's' }, 1 => { '.' => 'D', '/' => 'S' } ); | ||||
195 | |||||
196 | =begin TML | ||||
197 | |||||
198 | ---++ ClassMethod new( %constructor ) => $addrObj | ||||
199 | |||||
200 | Create a =Foswiki::Address= instance | ||||
201 | |||||
202 | The constructor takes two main forms: | ||||
203 | |||||
204 | ---+++ Explicit form | ||||
205 | *Example:* | ||||
206 | <verbatim> | ||||
207 | my $addrObj = Foswiki::Address->new( | ||||
208 | web => 'Web/SubWeb', | ||||
209 | topic => 'Topic', | ||||
210 | attachment => 'Attachment.pdf', | ||||
211 | rev => 3 | ||||
212 | );</verbatim> | ||||
213 | |||||
214 | *Options:* | ||||
215 | | *Param* | *Description* | *Notes* | | ||||
216 | | =web= | =$string= of web path, %BR% used if =webpath= is empty/null | | | ||||
217 | | =webpath= | =\@arrayref= of web path, root web first | | | ||||
218 | | =topic= | =$string= topic name | | | ||||
219 | | =rev= | =$integer= revision number. | If the tompath is to a =attachment= datastream, rev applies to that file; topic rev otherwise | | ||||
220 | | =tompath= | =\@arrayref= of a "TOM" path, one of:%BR% =META=, =text=, =SECTION=, =attachment=. | See table below | | ||||
221 | | =string= | string representation of an object | eg. 'Web/SubWeb.Topic/Attachment.pdf@3' | | ||||
222 | |||||
223 | *path forms:* | ||||
224 | | *tompath* | *Description* | | ||||
225 | | =['attachment']= | All datastreams attached to a topic | | ||||
226 | | =['attachment', 'Attachment.pdf']= | Datastream of the file attachment named 'Attachment.pdf' | | ||||
227 | | =['META']= | All =META= on a topic | | ||||
228 | | =['META', 'FIELD']= | All =META:FIELD= members on a topic | | ||||
229 | | =['META', 'FIELD', { name => 'Colour' }]= | The =META:FIELD= member whose =name='Colour'= | | ||||
230 | | =['META', 'FIELD', 3]= | The fourth =META:FIELD= member | | ||||
231 | | =['META', 'FIELD', { name => 'Colour' }, 'title']= | The ='title'= attribute on the =META:FIELD= member whose =name='Colour'= | | ||||
232 | | =['META', 'FIELD', 3, 'title']= | The ='title'= attribute on the fourth =META:FIELD= member | | ||||
233 | | =['text']= | The topic text | | ||||
234 | | =['SECTION']= | All topic sections as defined by %SYSTEMWEB%.VarSTARTSECTION | | ||||
235 | | =['SECTION', {name => 'foo'}]= | The topic section named 'foo' | | ||||
236 | | =['SECTION', {name => 'foo', type => 'include'}]= | The topic section named 'foo' of =type='include'= | | ||||
237 | |||||
238 | *Example:* Point to the value of a formfield =LastName= in =Web/SubWeb.Topic=, | ||||
239 | <verbatim> | ||||
240 | my $addrObj = Foswiki::Address->new( | ||||
241 | web => 'Web/SubWeb', | ||||
242 | topic => 'Topic', | ||||
243 | tompath => ['META', 'FIELD', {name => LastName}, 'value'] | ||||
244 | );</verbatim> | ||||
245 | |||||
246 | *Equivalent:* %JQREQUIRE{"chili"}%<verbatim class="tml"> | ||||
247 | %QUERY{"'Web/SubWeb.Topic'/META:FIELD[name='LastName'].value"}% | ||||
248 | or | ||||
249 | %QUERY{"'Web/SubWeb.Topic'/LastName"}% | ||||
250 | </verbatim> | ||||
251 | |||||
252 | ---+++ String form | ||||
253 | *Example:* | ||||
254 | <verbatim> | ||||
255 | my $addrObj = Foswiki::Address->new( | ||||
256 | string => 'Web/SubWeb.Topic/Attachment.pdf@3', | ||||
257 | %opts | ||||
258 | );</verbatim> | ||||
259 | |||||
260 | <blockquote class="foswikiHelp">%X% String form instantiation requires parsing | ||||
261 | of the address string which comes with many options and caveats - refer to the | ||||
262 | documentation for =parse()=.</blockquote> | ||||
263 | |||||
264 | =cut | ||||
265 | |||||
266 | sub new { | ||||
267 | my ( $class, %opts ) = @_; | ||||
268 | my $this; | ||||
269 | |||||
270 | if ( $opts{string} ) { | ||||
271 | |||||
272 | #ASSERT( not $opts{topic} or ( $opts{webpath} and $opts{topic} ) ) | ||||
273 | # if DEBUG; | ||||
274 | |||||
275 | if ( not $opts{isA} ) { | ||||
276 | |||||
277 | # transpose the existAs array into hash keys | ||||
278 | if ( $opts{existAs} ) { | ||||
279 | ASSERT( ref( $opts{existAs} ) eq 'ARRAY' ) if DEBUG; | ||||
280 | ASSERT( scalar( @{ $opts{existAs} } ) ) if DEBUG; | ||||
281 | $opts{existAsList} = $opts{existAs}; | ||||
282 | $opts{existAs} = { map { $_ => 1 } @{ $opts{existAs} } }; | ||||
283 | } | ||||
284 | else { | ||||
285 | $opts{existAsList} = $EXISTASLIST_DEFAULT; | ||||
286 | $opts{existAs} = $EXISTAS_DEFAULT; | ||||
287 | } | ||||
288 | } | ||||
289 | $this = bless( {}, $class ); | ||||
290 | $this->_parse( $opts{string}, \%opts ); | ||||
291 | } | ||||
292 | else { | ||||
293 | |||||
294 | # 'Web/SubWeb' vs [qw(Web SubWeb)] (supplied as web vs webpath): if the latter | ||||
295 | # is absent, derive it from the former (supplied as web vs webpath) | ||||
296 | if ( not $opts{webpath} and $opts{web} ) { | ||||
297 | $opts{webpath} = [ split( /[\/\.]/, $opts{web} ) ]; | ||||
298 | } | ||||
299 | |||||
300 | # $this = { | ||||
301 | # webpath => $opts{webpath}, | ||||
302 | # topic => $opts{topic}, | ||||
303 | # tompath => $opts{tompath}, | ||||
304 | # rev => $opts{rev}, | ||||
305 | # }; | ||||
306 | print STDERR "\$this: " . Data::Dumper->Dump( [ \%opts ] ) | ||||
307 | if TRACEATTACH; | ||||
308 | if ( $opts{attachment} and not $opts{tompath} ) { | ||||
309 | print STDERR "Assigning {tompath} from {attachment}\n" | ||||
310 | if TRACEATTACH; | ||||
311 | $opts{tompath} = [ 'attachment', $opts{attachment} ]; | ||||
312 | } | ||||
313 | elsif ( not $opts{attachment} | ||||
314 | and $opts{tompath} | ||||
315 | and ref( $opts{tompath} ) eq 'ARRAY' | ||||
316 | and $opts{tompath}->[0] eq 'attachment' | ||||
317 | and $opts{tompath}->[1] ) | ||||
318 | { | ||||
319 | print STDERR "Assigning {attachment} from {tompath}\n" | ||||
320 | if TRACEATTACH; | ||||
321 | $opts{attachment} = $opts{tompath}->[1]; | ||||
322 | } | ||||
323 | if ( DEBUG and $opts{attachment} and $opts{tompath} ) { | ||||
324 | ASSERT( | ||||
325 | ref( $opts{tompath} ) eq 'ARRAY' | ||||
326 | and $opts{tompath}->[0] ne 'attachment' | ||||
327 | or ( $opts{tompath}->[1] | ||||
328 | and $opts{tompath}->[1] eq $opts{attachment} ) | ||||
329 | ) if DEBUG; | ||||
330 | } | ||||
331 | |||||
332 | #$this->_parse( $_[0]->{string} ); | ||||
333 | $this = bless( \%opts, $class ); | ||||
334 | } | ||||
335 | |||||
336 | #push(@THESE, $this); | ||||
337 | |||||
338 | return $this; | ||||
339 | } | ||||
340 | |||||
341 | =begin TML | ||||
342 | |||||
343 | ---++ ClassMethod finish( ) | ||||
344 | |||||
345 | Clean up the object, releasing any memory stored in it. | ||||
346 | |||||
347 | =cut | ||||
348 | |||||
349 | sub finish { | ||||
350 | my ($this) = @_; | ||||
351 | |||||
352 | $this->{root} = undef; | ||||
353 | $this->{web} = undef; | ||||
354 | $this->{webpath} = undef; | ||||
355 | $this->{topic} = undef; | ||||
356 | $this->{rev} = undef; | ||||
357 | $this->{tompath} = undef; | ||||
358 | $this->{attachment} = undef; | ||||
359 | $this->{isA} = undef; | ||||
360 | $this->{type} = undef; | ||||
361 | $this->{stringified} = undef; | ||||
362 | |||||
363 | return; | ||||
364 | } | ||||
365 | |||||
366 | =begin TML | ||||
367 | |||||
368 | ---++ PRIVATE ClassMethod _parse( $string, \%opts ) -> $success | ||||
369 | |||||
370 | Parse the given string using options provided and update the instance with the | ||||
371 | resulting address. | ||||
372 | |||||
373 | Examples of valid path strings include: | ||||
374 | |||||
375 | * =Web/= | ||||
376 | * =Web/SubWeb/= | ||||
377 | * =Web/SubWeb.Topic= or =Web/SubWeb/Topic= or =Web.SubWeb.Topic= | ||||
378 | * =Web/SubWeb.Topic@2= or =Web/SubWeb/Topic@2= or =Web.SubWeb.Topic@2= | ||||
379 | * =Web/SubWeb.Topic/Attachment.pdf= or =Web/SubWeb/Topic/Attachment.pdf= or | ||||
380 | =Web.SubWeb.Topic/Attachment.pdf= | ||||
381 | * =Web/SubWeb.Topic/Attachment.pdf@3= or =Web/SubWeb/Topic/Attachment.pdf@3= | ||||
382 | or =Web.SubWeb.Topic/Attachment.pdf@3= | ||||
383 | |||||
384 | "String" addresses are notoriously ambiguous: Foswiki traditionally allows web | ||||
385 | & topic separators '.' & '/' to be used interchangably. For example, the | ||||
386 | following strings could be topics or attachments (or even webs): | ||||
387 | * =Foo.Bar= | ||||
388 | * =Foo.Bar.Cat.Dog= | ||||
389 | * =Foo/Bar= | ||||
390 | * =Foo/Bar/Cat/Dog= | ||||
391 | |||||
392 | To resolve the ambiguity, components of ambiguous strings are tested for | ||||
393 | existence as webs, topics or attachments and used as hints to help resolve them, | ||||
394 | so it follows that: | ||||
395 | <blockquote class="foswikiHelp">%X% Ambiguous address strings cannot be | ||||
396 | considered stable; exactly which resource they resolve to depends on the | ||||
397 | hinting algorithm, the parameters and hints supplied to it, and the existence | ||||
398 | (or non-existence) of other resources</blockquote> | ||||
399 | |||||
400 | *Options:* | ||||
401 | | *Param* | *Description* | *Values* | *Notes* | | ||||
402 | | =webpath= or =web= %BR% =topic= | context hints | refer to explicit form |\ | ||||
403 | if =string= is ambiguous (and possibly not fully qualified, Eg. topic-only or\ | ||||
404 | attachment-only), the hinting algorithm tests =string= against them | | ||||
405 | | =isA= | resource type specification | =$type= - 'web', 'topic',\ | ||||
406 | 'attachment' | parse =string= to resolve to the specified type; exist hinting\ | ||||
407 | is skipped | | ||||
408 | | =catchAs= | default resource type | =$type= - 'web', 'topic', 'attachment', 'none' |\ | ||||
409 | if =string= is ambiguous AND (exist hinting fails OR is disabled), THEN\ | ||||
410 | assume =string= to be (web, topic, file attachment or unparseable) | | ||||
411 | | =existAs= | resource types to test | =\@typelist= containing one\ | ||||
412 | or more of 'web', 'topic', 'attachment' | if =string= is ambiguous, test (in\ | ||||
413 | order) as each of the specified types. Default: =[qw(attachment topic)]= | | ||||
414 | | =existHints= | exist hinting enable/disable | =$boolean= |\ | ||||
415 | enable/disable hinting through web/topic/attachment existence checks.\ | ||||
416 | =string= *is assumed to be using the 'unambiguous' conventions below*; if it\ | ||||
417 | isn't, =catchAs= is used | | ||||
418 | |||||
419 | #UnambiguousStrings | ||||
420 | ---+++ Unambiguous strings | ||||
421 | |||||
422 | To build less ambiguous address strings, use the following conventions: | ||||
423 | * Terminate web addresses with '/' | ||||
424 | * Separate subwebs in the web path with '/' | ||||
425 | * Separate topic from web path with '.' | ||||
426 | * Separate file attachments from topics with '/' | ||||
427 | Examples: | ||||
428 | * =Web/SubWeb/=, =Web/= | ||||
429 | * =Web/SubWeb.Topic= | ||||
430 | * =Web.Topic/Attachment.pdf= | ||||
431 | * =Web/SubWeb.Topic/Attachment.pdf= | ||||
432 | |||||
433 | Many strings commonly used in Foswiki will always be ambiguous (such as =Foo=, | ||||
434 | =Foo/Bar=, =Foo/Bar/Cat=, =Foo.Bar.Cat=). Supplying an =isA= specification will | ||||
435 | prevent the parser from using the (somewhat expensive) exist hinting heuristics. | ||||
436 | |||||
437 | <blockquote class="foswikiHelp">%I% In order to simplify the algorithm, a | ||||
438 | string may only parse out as a web if: | ||||
439 | * It is of the form =Foo/=, or | ||||
440 | * =isA => 'web'= is specified, or | ||||
441 | * No other type is possible, and =catchAs => 'web'= is specified | ||||
442 | </blockquote> | ||||
443 | |||||
444 | The exist hinting algorithm is skipped if: | ||||
445 | * =isA= specified | ||||
446 | * =string= not ambiguous | ||||
447 | |||||
448 | If =string= is ambiguous, the hinting algorithm works roughly as follows: | ||||
449 | * if exist hinting is disabled | ||||
450 | * and =catchAs= is specified (parse as the =catchAs= type), otherwise | ||||
451 | * the string cannot be parsed | ||||
452 | * if exist hinting is enabled, the string is checked for existence as each of | ||||
453 | the =existAs= types (default is 'attachment', 'topic') | ||||
454 | * if there is an exact match against one of the =existAs= types (finish), otherwise | ||||
455 | * if there were partial matches (select the combination which scores | ||||
456 | highest), otherwise | ||||
457 | * if =catchAs= was specified (parse as that type), otherwise | ||||
458 | * the string cannot be parsed | ||||
459 | The following table attempts to explain how ambiguous forms can be interpreted | ||||
460 | and resolved. | ||||
461 | | *String form* | *existHints* | *ambiguous* | *web[s]* | *topic* | *possible types* | | ||||
462 | | =Foo/= | | | | | web | | ||||
463 | | =Foo= | | %X% | | | web %BR% needs =isA => 'web'= or =catchAs => 'web'=,%BR% error otherwise | | ||||
464 | | =Foo= | | | set | | topic | | ||||
465 | | =Foo= | | 1 | set | set | topic, attachment | | ||||
466 | | =Foo/Bar/= | | | | | web | | ||||
467 | | =Foo/Bar= | | | | | topic | | ||||
468 | | =Foo/Bar= | | 1 | set | | topic, attachment | | ||||
469 | | =Foo.Bar= | | | | | topic | | ||||
470 | | =Foo.Bar= | | 1 | set | set | topic, attachment | | ||||
471 | | =Foo/Bar/Dog/= | | | | | web | | ||||
472 | | =Foo/Bar/Dog= | | 1 | | | topic, attachment | | ||||
473 | | =Foo.Bar/Dog= | 0 | | | | attachment | | ||||
474 | | =Foo.Bar/Dog= | | 1 | | | topic, attachment | | ||||
475 | | =Foo.Bar/D.g= | | | | | attachment | | ||||
476 | | =Foo/Bar.Dog= | | | | | topic | | ||||
477 | | =Foo/Bar.Dog= | | 1 | set | | topic, attachment | | ||||
478 | | =Foo.Bar.Dog= | | | | | topic | | ||||
479 | | =Foo.Bar.Dog= | | 1 | set | set | topic, attachment | | ||||
480 | | =Foo/Bar/Dog/Cat/= | | | | | web | | ||||
481 | | =Foo/Bar.Dog.Cat= | | | | | topic | | ||||
482 | | =Foo/Bar.Dog.Cat= | | 1 | set | | topic, attachment | | ||||
483 | | =Foo/Bar.Dog/Cat= | | | | | attachment | | ||||
484 | | =Foo/Bar.Dog/C.t= | | | | | attachment | | ||||
485 | | =Foo/Bar/Dog.Cat= | 0 | | | | topic | | ||||
486 | | =Foo/Bar/Dog.Cat= | | 1 | | | topic, attachment | | ||||
487 | | =Foo/Bar/Dog/Cat= | | 1 | | | topic, attachment | | ||||
488 | | =Foo/Bar/Dog/C.t= | | 1 | | | topic, attachment | | ||||
489 | | =Foo.Bar.Dog/Cat= | 0 | | | | attachment | | ||||
490 | | =Foo.Bar.Dog/Cat= | | 1 | | | topic, attachment | | ||||
491 | | =Foo.Bar.Dog/C.t= | | | | | attachment | | ||||
492 | |||||
493 | =cut | ||||
494 | |||||
495 | sub _parse { | ||||
496 | my ( $this, $path, $opts ) = @_; | ||||
497 | |||||
498 | print STDERR "parse(): parsing '$path'\n" if TRACE2; | ||||
499 | $this->_invalidate(); | ||||
500 | if ( not defined $opts ) { | ||||
501 | $opts = { | ||||
502 | web => $opts->{web}, | ||||
503 | webpath => $opts->{webpath}, | ||||
504 | topic => $opts->{topic}, | ||||
505 | rev => $opts->{rev}, | ||||
506 | existAsList => [qw(attachment topic)], | ||||
507 | existAs => { attachment => 1, topic => 1 } | ||||
508 | }; | ||||
509 | } | ||||
510 | ASSERT( | ||||
511 | ( !defined $opts->{rev} || $opts->{rev} =~ m/^[-\+]?\d+$/ ), | ||||
512 | "rev: '" | ||||
513 | . ( defined $opts->{rev} ? $opts->{rev} : 'undef' ) | ||||
514 | . "' is numeric" | ||||
515 | ) if DEBUG; | ||||
516 | ASSERT( $opts->{isA} or defined $opts->{existAs} ) if DEBUG; | ||||
517 | if ( $path =~ s/\@([-\+]?\d+)$// ) { | ||||
518 | $this->{rev} = $1; | ||||
519 | } | ||||
520 | |||||
521 | # if necessary, populate webpath from web parameter | ||||
522 | if ( not $opts->{webpath} and $opts->{web} ) { | ||||
523 | $opts->{webpath} = [ split( /[\/\.]/, $opts->{web} ) ]; | ||||
524 | } | ||||
525 | |||||
526 | ASSERT( not $opts->{webpath} or ref( $opts->{webpath} ) eq 'ARRAY' ) | ||||
527 | if DEBUG; | ||||
528 | |||||
529 | # Because of the way we split, 'Foo/' causes final element to be empty | ||||
530 | if ( $opts->{webpath} and not $opts->{webpath}->[-1] ) { | ||||
531 | pop( @{ $opts->{webpath} } ); | ||||
532 | } | ||||
533 | |||||
534 | # pre-compute web's string form (avoid unnecessary join()s) | ||||
535 | if ( not $opts->{web} and $opts->{webpath} ) { | ||||
536 | $opts->{web} = join( '/', @{ $opts->{webpath} } ); | ||||
537 | } | ||||
538 | |||||
539 | # Is the path explicit? | ||||
540 | if ( not $opts->{isA} ) { | ||||
541 | if ( substr( $path, -1, 1 ) eq '/' ) { | ||||
542 | if ( length($path) > 1 ) { | ||||
543 | $opts->{isA} = 'web'; | ||||
544 | } | ||||
545 | else { | ||||
546 | |||||
547 | # $path eq '/' - the mythical "root" path | ||||
548 | $opts->{isA} = 'root'; | ||||
549 | } | ||||
550 | } | ||||
551 | elsif ( substr( $path, 0, 1 ) eq '\'' or $path =~ m/\[/ ) { | ||||
552 | $opts->{isA} = '*'; | ||||
553 | } | ||||
554 | } | ||||
555 | |||||
556 | # Here we go... short-circuit testing if we already have an isA spec | ||||
557 | if ( $opts->{isA} ) { | ||||
558 | |||||
559 | print STDERR "parse(): isA: $opts->{isA}\n" if TRACE2; | ||||
560 | ASSERT( $atomiseAs{ $opts->{isA} } ) if DEBUG; | ||||
561 | $atomiseAs{ $opts->{isA} }->( $this, $this, $path, $opts ); | ||||
562 | } | ||||
563 | else { | ||||
564 | my @separators = ( $path =~ m/([\.\/])/g ); | ||||
565 | my $sepboost = 0; | ||||
566 | my $sepident = ''; | ||||
567 | my $lastsep; | ||||
568 | my $plaus; | ||||
569 | my @trylist; | ||||
570 | my $normalform; | ||||
571 | my %typeatoms; | ||||
572 | my %typescores; | ||||
573 | my $parsed; | ||||
574 | |||||
575 | ASSERT( ref( $opts->{existAsList} ) eq 'ARRAY' ) if DEBUG; | ||||
576 | |||||
577 | if ( scalar(@separators) ) { | ||||
578 | |||||
579 | # build the separator-based identity of the path string, Eg. | ||||
580 | # Foo/Bar/Dog.Cat/B.a.t = 'SdsD' | ||||
581 | # TemporaryAddressTestsTestWeb/SubWeb/SubSubWeb.Topic/Atta.hme.t | ||||
582 | foreach my $sep (@separators) { | ||||
583 | if ( defined $lastsep ) { | ||||
584 | if ( $lastsep ne $sep ) { | ||||
585 | $sepident .= $sepidentchars{$sepboost}->{$lastsep}; | ||||
586 | $lastsep = $sep; | ||||
587 | $sepboost = 0; | ||||
588 | } | ||||
589 | else { | ||||
590 | $sepboost = 1; | ||||
591 | } | ||||
592 | } | ||||
593 | else { | ||||
594 | $lastsep = $sep; | ||||
595 | } | ||||
596 | } | ||||
597 | $sepident .= $sepidentchars{$sepboost}->{$lastsep}; | ||||
598 | } | ||||
599 | $plaus = $plausibletable{$sepident}; | ||||
600 | print STDERR "Identity\t$sepident calculated for $path, plaustable: " | ||||
601 | . Data::Dumper->Dump( [$plaus] ) | ||||
602 | if TRACE; | ||||
603 | |||||
604 | # Is the identity known? | ||||
605 | if ($plaus) { | ||||
606 | |||||
607 | # Default to exist hinting enabled | ||||
608 | if ( not defined $opts->{existHints} ) { | ||||
609 | $opts->{existHints} = 1; | ||||
610 | } | ||||
611 | |||||
612 | # (ab)using %opts to match values from the plausible table | ||||
613 | $opts->{1} = 1; | ||||
614 | $opts->{2} = 1; | ||||
615 | |||||
616 | # @trylist is the intersection of existAs list and the plausible | ||||
617 | # list. existAs ordering is used unless string is "unambiguous" | ||||
618 | # form, in which case that type is positioned first. | ||||
619 | foreach my $type ( @{ $opts->{existAsList} } ) { | ||||
620 | |||||
621 | # If the type is plausible, and the options support it | ||||
622 | if ( $plaus->{$type} and $opts->{ $plaus->{$type} } ) { | ||||
623 | |||||
624 | # If an "unambiguous" form, put it first in the @trylist. | ||||
625 | if ( $plaus->{$type} eq 2 ) { | ||||
626 | unshift( @trylist, $type ); | ||||
627 | $normalform = $type; | ||||
628 | |||||
629 | # If existHints are allowed, add the plausible type to list | ||||
630 | } | ||||
631 | elsif ( $opts->{existHints} ) { | ||||
632 | push( @trylist, $type ); | ||||
633 | } | ||||
634 | } | ||||
635 | } | ||||
636 | |||||
637 | # Exist hinting. The first complete hit, or the hit which matches | ||||
638 | # the most (out of the existAsList, Eg.: attachment, topic, web) | ||||
639 | # wins. The former should naturally fall out of the latter, unless | ||||
640 | # the existAs list is not ordered smallestthing-first | ||||
641 | if ( $opts->{existHints} ) { | ||||
642 | my $i = 0; | ||||
643 | my $ntrylist = scalar(@trylist); | ||||
644 | my $besttype; | ||||
645 | my $bestscore; | ||||
646 | my $bestscoredtype; | ||||
647 | |||||
648 | # If a complete hit is detected, we set $besttype & exit early | ||||
649 | while ( $ntrylist > $i and not $besttype ) { | ||||
650 | my $score; | ||||
651 | my $type = $trylist[$i]; | ||||
652 | |||||
653 | $i += 1; | ||||
654 | print STDERR "Trying to atomise $path as $type...\n" | ||||
655 | if TRACE; | ||||
656 | ASSERT( $atomiseAs{$type} ) if DEBUG; | ||||
657 | $typeatoms{$type} = | ||||
658 | $atomiseAs{$type}->( $this, {}, $path, $opts ); | ||||
659 | print STDERR "Atomised $path as $type, result: " | ||||
660 | . Data::Dumper->Dump( [ $typeatoms{$type} ] ) | ||||
661 | if TRACE; | ||||
662 | ( $besttype, $score ) = | ||||
663 | $this->_existScore( $typeatoms{$type}, $type ); | ||||
664 | |||||
665 | if (TRACE) { | ||||
666 | print STDERR 'existScore: ' | ||||
667 | . ( $score || '' ) | ||||
668 | . ' besttype: ' | ||||
669 | . ( $besttype || '' ) . "\n"; | ||||
670 | } | ||||
671 | |||||
672 | if ( $score | ||||
673 | and ( not defined $bestscore or $bestscore < $score ) ) | ||||
674 | { | ||||
675 | $bestscoredtype = $type; | ||||
676 | $bestscore = $score; | ||||
677 | } | ||||
678 | } | ||||
679 | |||||
680 | # Unless we already got a perfect hit; find the type for this | ||||
681 | # path that gives the highest score | ||||
682 | if ( not $besttype ) { | ||||
683 | $besttype = $bestscoredtype; | ||||
684 | } | ||||
685 | |||||
686 | # Copy the atoms from the best hit into our instance. | ||||
687 | if ($besttype) { | ||||
688 | $this->{web} = $typeatoms{$besttype}->{web}; | ||||
689 | $this->{webpath} = $typeatoms{$besttype}->{webpath}; | ||||
690 | $this->{topic} = $typeatoms{$besttype}->{topic}; | ||||
691 | $this->{tompath} = $typeatoms{$besttype}->{tompath}; | ||||
692 | $this->{attachment} = $typeatoms{$besttype}->{attachment}; | ||||
693 | $parsed = 1; | ||||
694 | } | ||||
695 | } | ||||
696 | } | ||||
697 | if ( not $parsed ) { | ||||
698 | my $type = $normalform || $opts->{catchAs}; | ||||
699 | |||||
700 | if ($type) { | ||||
701 | ASSERT( $atomiseAs{$type} ) if DEBUG; | ||||
702 | $typeatoms{$type} = | ||||
703 | $atomiseAs{$type}->( $this, $this, $path, $opts ); | ||||
704 | } | ||||
705 | } | ||||
706 | } | ||||
707 | |||||
708 | return $this->isValid(); | ||||
709 | } | ||||
710 | |||||
711 | #sub _atomiseAs { | ||||
712 | # my ( $this, $that, $path, $type, $opts ) = @_; | ||||
713 | # | ||||
714 | # ASSERT($path) if DEBUG; | ||||
715 | # ASSERT($type) if DEBUG; | ||||
716 | # ASSERT( $atomiseAs{$type} ) if DEBUG; | ||||
717 | # $atomiseAs{$type}->( $this, $that, $path, $opts ); | ||||
718 | # | ||||
719 | # return $that; | ||||
720 | #} | ||||
721 | |||||
722 | sub _atomiseAsRoot { | ||||
723 | my ( $this, $that, $path, $opts ) = @_; | ||||
724 | |||||
725 | print STDERR "_atomiseAsRoot():\n" if TRACE2; | ||||
726 | ASSERT( $path eq '/' ) if DEBUG; | ||||
727 | $that->{root} = 1; | ||||
728 | $that->{web} = undef; | ||||
729 | $that->{webpath} = undef; | ||||
730 | $that->{topic} = undef; | ||||
731 | $that->{tompath} = undef; | ||||
732 | $that->{attachment} = undef; | ||||
733 | |||||
734 | return $that; | ||||
735 | } | ||||
736 | |||||
737 | sub _atomiseAsWeb { | ||||
738 | my ( $this, $that, $path, $opts ) = @_; | ||||
739 | |||||
740 | print STDERR "_atomiseAsWeb():\n" if TRACE2; | ||||
741 | $that->{web} = $path; | ||||
742 | $that->{webpath} = [ split( /[\.\/]/, $path ) ]; | ||||
743 | ASSERT( $that->{web} and ref( $that->{webpath} ) eq 'ARRAY' ) if DEBUG; | ||||
744 | |||||
745 | # If we had a path that looks like 'Foo/' | ||||
746 | if ( not $that->{webpath}->[-1] ) { | ||||
747 | pop( @{ $that->{webpath} } ); | ||||
748 | chop( $that->{web} ); | ||||
749 | } | ||||
750 | $that->{topic} = undef; | ||||
751 | $that->{tompath} = undef; | ||||
752 | $that->{attachment} = undef; | ||||
753 | |||||
754 | return $that; | ||||
755 | } | ||||
756 | |||||
757 | sub _atomiseAsTopic { | ||||
758 | my ( $this, $that, $path, $opts ) = @_; | ||||
759 | ASSERT($path) if DEBUG; | ||||
760 | my @parts = split( /[\.\/]/, $path ); | ||||
761 | my $nparts = scalar(@parts); | ||||
762 | |||||
763 | print STDERR "_atomiseAsTopic(): path: $path, nparts: $nparts\n" if TRACE2; | ||||
764 | if ( $nparts == 1 ) { | ||||
765 | if ( $opts->{webpath} | ||||
766 | and ref( $opts->{webpath} ) eq 'ARRAY' | ||||
767 | and scalar( @{ $opts->{webpath} } ) ) | ||||
768 | { | ||||
769 | $that->{web} = $opts->{web}; | ||||
770 | $that->{webpath} = $opts->{webpath}; | ||||
771 | $that->{topic} = $path; | ||||
772 | } | ||||
773 | } | ||||
774 | else { | ||||
775 | $that->{webpath} = [ @parts[ 0 .. ( $nparts - 2 ) ] ]; | ||||
776 | $that->{web} = undef; | ||||
777 | |||||
778 | # $that->{web} = join( '/', @{ $that->{webpath} } ); | ||||
779 | $that->{topic} = $parts[-1]; | ||||
780 | } | ||||
781 | $that->{tompath} = undef; | ||||
782 | $that->{attachment} = undef; | ||||
783 | ASSERT( $that->{webpath} or not $that->{topic} ) if DEBUG; | ||||
784 | |||||
785 | # ASSERT( $that->{web} ) if DEBUG; | ||||
786 | |||||
787 | return $that; | ||||
788 | } | ||||
789 | |||||
790 | sub _atomiseAsAttachment { | ||||
791 | my ( $this, $that, $path, $opts ) = @_; | ||||
792 | |||||
793 | print STDERR "_atomiseAsAttachment():\n" if TRACE2; | ||||
794 | ASSERT($path) if DEBUG; | ||||
795 | if ( my ( $lhs, $file ) = ( $path =~ m/^(.*?)\/([^\/]+)$/ ) ) { | ||||
796 | $that = $this->_atomiseAsTopic( $that, $lhs, $opts ); | ||||
797 | $that->{tompath} = [ 'attachment', $file ]; | ||||
798 | $that->{attachment} = $file; | ||||
799 | } | ||||
800 | else { | ||||
801 | if ( $opts->{webpath} and $opts->{topic} ) { | ||||
802 | $that->{webpath} = $opts->{webpath}; | ||||
803 | $that->{web} = $opts->{web}; | ||||
804 | $that->{topic} = $opts->{topic}; | ||||
805 | $that->{tompath} = [ 'attachment', $path ]; | ||||
806 | $that->{attachment} = $path; | ||||
807 | } | ||||
808 | } | ||||
809 | |||||
810 | return $that; | ||||
811 | } | ||||
812 | |||||
813 | =begin TML | ||||
814 | |||||
815 | ---++ PRIVATE ClassMethod _atomiseAsTOM ( $that, $path, $opts ) => $that | ||||
816 | |||||
817 | Parse a small subset ('static' meta path forms) of QuerySearch (VarQUERY) | ||||
818 | compatible expressions. | ||||
819 | |||||
820 | =$opts= is a hashref holding default context | ||||
821 | |||||
822 | 'topic'/ ref part is optional; =_atomiseAsTOM()= falls-back to default topic | ||||
823 | context supplied in =$opts= otherwise. In other words, both of these forms are | ||||
824 | supported: | ||||
825 | * ='Web/SubWeb.Topic@3'/META:FIELD[name='Colour'].value= | ||||
826 | * =META:FIELD[name='Colour'].value= | ||||
827 | |||||
828 | | *Form* | *tompath* | *type* | | ||||
829 | | =META= | =['META']= | meta | | ||||
830 | | =META:FIELD= | =['META', 'FIELD']= | metatype | | ||||
831 | | =META:FIELD[name='Colour']= | =['META', 'FIELD', {name => 'Colour'}]= | metamember | | ||||
832 | | =META:FIELD[3]= | =['META', 'FIELD', 3]= | metamember | | ||||
833 | | =META:FIELD[name='Colour'].value= | =['META', 'FIELD', {name => 'Colour'}, 'value']= | metakey | | ||||
834 | | =META:FIELD[3].value= | =['META', 'FIELD', 3, 'value']= | metakey | | ||||
835 | | =fields= | =['META', 'FIELD']= | metatype | | ||||
836 | | =fields[name='Colour']= | =['META', 'FIELD', {name => 'Colour'}]= | metamember | | ||||
837 | | =fields[3]= | =['META', 'FIELD', 3]= | metamember | | ||||
838 | | =fields[name='Colour'].value= | =['META', 'FIELD', 3, 'value']= | metakey | | ||||
839 | | =MyForm= | =['META', 'FIELD', {form => 'MyForm'}]= | metatype | | ||||
840 | | =MyForm[name='Colour']= | =['META', 'FIELD', {form => 'MyForm', name => 'Colour'}]= | metamember | | ||||
841 | | =MyForm[name='Colour'].value= | =['META', 'FIELD', {form => 'MyForm', name => 'Colour'}, 'value']= | metakey | | ||||
842 | | =MyForm.Colour= | =['META', 'FIELD', {form => 'MyForm', name => 'Colour'}, 'value']= | metakey | | ||||
843 | | =Colour= | =['META', 'FIELD', {name => 'Colour'}, 'value']= | metakey | | ||||
844 | =cut | ||||
845 | |||||
846 | sub _atomiseAsTOM { | ||||
847 | my ( $this, $that, $path, $opts ) = @_; | ||||
848 | |||||
849 | print STDERR "_atomiseAsTOM():\n" if TRACE2; | ||||
850 | |||||
851 | # QuerySearch meta path? | ||||
852 | # SMELL: This should be done in the query parser... | ||||
853 | # ... or at least use Regexp::Grammars | ||||
854 | # TODO: member selectors may only be on 1 or 2 keys, or array index | ||||
855 | if ( | ||||
856 | $path =~ m/^ | ||||
857 | ( # 1 | ||||
858 | '([^']+)' # 2 'Web.Topic@123' | ||||
859 | \s* \/ \s* | ||||
860 | )? | ||||
861 | (META:)? # 3 META: | ||||
862 | ([^\[\s\.]+) # 4 PART, FIELD, alias, MyForm, FieldName | ||||
863 | (\s* \[ \s* # 5 [............] | ||||
864 | ( # 6 n (or) | ||||
865 | [-\+]?\d+ | ||||
866 | |( # 7 name='foo'[ AND bar='cat' [ AND dog='bat' ...]] | ||||
867 | ([^=\s]+) # 8 name | ||||
868 | \s* = \s* # = | ||||
869 | '([^']+)' # 9 'foo' | ||||
870 | ( # 10 multi-key selector? | ||||
871 | \s* AND \s* | ||||
872 | ([^=\s]+) # 11 bar | ||||
873 | \s* = \s* # = | ||||
874 | '([^']+)' # 12 'cat' | ||||
875 | )? | ||||
876 | ) | ||||
877 | ) | ||||
878 | \s* \])? | ||||
879 | (\s* \. \s* # 13 . | ||||
880 | (\w+?) # 14 value | ||||
881 | )? | ||||
882 | $/x | ||||
883 | ) | ||||
884 | { | ||||
885 | my $webtopicrev = $2; | ||||
886 | my @tompath; | ||||
887 | my $doneselector; | ||||
888 | my $doneaccessor; | ||||
889 | |||||
890 | if ($3) { # META: | ||||
891 | @tompath = ('META'); | ||||
892 | push( @tompath, $4 ); | ||||
893 | if ( not $5 and $14 ) { # Eg. META:TOPICINFO.author | ||||
894 | push( @tompath, undef, $14 ); | ||||
895 | $doneselector = 1; | ||||
896 | $doneaccessor = 1; | ||||
897 | } | ||||
898 | } | ||||
899 | elsif ( $pathtypes{$4} ) { # META, attachment, SECTION, text | ||||
900 | @tompath = ($4); | ||||
901 | } | ||||
902 | elsif ( $Foswiki::Meta::aliases{$4} ) { # fields, attachments, info | ||||
903 | @tompath = ('META'); | ||||
904 | |||||
905 | # strip off the 'META:' part | ||||
906 | push( @tompath, substr( $Foswiki::Meta::aliases{$4}, 5 ) ); | ||||
907 | if ( not $5 and $14 ) { # Eg. info.author | ||||
908 | push( @tompath, undef, $14 ); | ||||
909 | $doneselector = 1; | ||||
910 | $doneaccessor = 1; | ||||
911 | } | ||||
912 | } | ||||
913 | elsif ($4) { # SomeFormField or SomethingForm | ||||
914 | @tompath = ('META'); | ||||
915 | push( @tompath, 'FIELD' ); | ||||
916 | if ( not( $14 or $6 ) ) { # SomeFormField | ||||
917 | # SMELL: This catches "'Web.Topic@123'/MyForm" & "MyForm" | ||||
918 | push( @tompath, { name => $4 }, 'value' ); | ||||
919 | $doneselector = 1; | ||||
920 | $doneaccessor = 1; | ||||
921 | } | ||||
922 | elsif ( substr( $4, -4, 4 ) eq 'Form' ) { # SomethingForm | ||||
923 | push( @tompath, { form => $4 } ); | ||||
924 | if ($8) { # SomethingForm[a=b | ||||
925 | ASSERT( defined $9 ) if DEBUG; | ||||
926 | $tompath[-1]->{$8} = $9; | ||||
927 | if ($11) { # SomethingForm[a=b AND c=d] | ||||
928 | ASSERT( defined $12 ) if DEBUG; | ||||
929 | $tompath[-1]->{$11} = $12; | ||||
930 | } | ||||
931 | $doneselector = 1; | ||||
932 | } | ||||
933 | elsif ($6) { # SomethingForm[n] | ||||
934 | push( @tompath, $6 ); | ||||
935 | $doneselector = 1; | ||||
936 | ASSERT( $6 =~ m/^\d+$/ ) if DEBUG; | ||||
937 | } | ||||
938 | elsif ($14) { | ||||
939 | $tompath[-1]->{name} = $14; | ||||
940 | push( @tompath, 'value' ); | ||||
941 | $doneaccessor = 1; | ||||
942 | } | ||||
943 | } | ||||
944 | else { # form not /Form$/ or alias from disabled plugin | ||||
945 | ASSERT(0) if DEBUG; | ||||
946 | } | ||||
947 | } | ||||
948 | else { # Shouldn't get here | ||||
949 | ASSERT(0) if DEBUG; | ||||
950 | } | ||||
951 | if ( not $doneselector and $6 ) { # SOMETHING[...] | ||||
952 | if ($8) { # SOMETHING[a=b | ||||
953 | ASSERT( defined $9 ) if DEBUG; | ||||
954 | push( @tompath, { $8 => $9 } ); | ||||
955 | if ($11) { # SOMETHING[a=b AND c=d] | ||||
956 | ASSERT( defined $12 ) if DEBUG; | ||||
957 | $tompath[-1]->{$11} = $12; | ||||
958 | } | ||||
959 | } | ||||
960 | else { # SOMETHING[n] | ||||
961 | ASSERT($6) if DEBUG; | ||||
962 | push( @tompath, $6 ); | ||||
963 | ASSERT( $6 =~ m/^\d+$/ ) if DEBUG; | ||||
964 | } | ||||
965 | $doneselector = 1; | ||||
966 | } | ||||
967 | if ( not $doneaccessor and $14 ) { | ||||
968 | push( @tompath, $14 ); | ||||
969 | } | ||||
970 | $that->{tompath} = \@tompath; | ||||
971 | if ($webtopicrev) { | ||||
972 | my $refAddr = Foswiki::Address->new( | ||||
973 | string => $webtopicrev, | ||||
974 | isA => 'topic', | ||||
975 | webpath => $opts->{webpath}, | ||||
976 | web => $opts->{web} | ||||
977 | ); | ||||
978 | |||||
979 | $that->{web} = $refAddr->{web}; | ||||
980 | $that->{webpath} = $refAddr->{webpath}; | ||||
981 | $that->{topic} = $refAddr->{topic}; | ||||
982 | $that->{rev} = $refAddr->{rev}; | ||||
983 | ASSERT( | ||||
984 | ( !defined $that->{rev} || $that->{rev} =~ m/^[-\+]?\d+$/ ), | ||||
985 | "rev '" | ||||
986 | . ( defined $that->{rev} ? $that->{rev} : 'undef' ) | ||||
987 | . "' is numeric" | ||||
988 | ) if DEBUG; | ||||
989 | } | ||||
990 | else { | ||||
991 | $that->{webpath} = $opts->{webpath}; | ||||
992 | $that->{topic} = $opts->{topic}; | ||||
993 | $that->{rev} = undef; | ||||
994 | ASSERT( $that->{webpath} ) if DEBUG; | ||||
995 | ASSERT( $that->{topic} ) if DEBUG; | ||||
996 | } | ||||
997 | } | ||||
998 | |||||
999 | return $that; | ||||
1000 | } | ||||
1001 | |||||
1002 | sub _existScore { | ||||
1003 | my ( $this, $atoms, $type ) = @_; | ||||
1004 | my $score; | ||||
1005 | my $perfecttype; | ||||
1006 | |||||
1007 | ASSERT( not $atoms->{tompath} or ref( $atoms->{tompath} ) eq 'ARRAY' ) | ||||
1008 | if DEBUG; | ||||
1009 | ASSERT( $atoms->{web} or ref( $atoms->{webpath} ) eq 'ARRAY' ) if DEBUG; | ||||
1010 | if ( | ||||
1011 | $atoms->{tompath} | ||||
1012 | and scalar( @{ $atoms->{tompath} } ) == 2 | ||||
1013 | and ( $atoms->{tompath}->[0] eq 'attachment' ) | ||||
1014 | and Foswiki::Func::attachmentExists( | ||||
1015 | $atoms->{web}, $atoms->{topic}, $atoms->{tompath}->[1] | ||||
1016 | ) | ||||
1017 | ) | ||||
1018 | { | ||||
1019 | ASSERT( $atoms->{attachment} | ||||
1020 | and $atoms->{attachment} eq $atoms->{tompath}->[1] ) | ||||
1021 | if DEBUG; | ||||
1022 | $perfecttype = $type; | ||||
1023 | $score = 2 + scalar( @{ $atoms->{webpath} } ); | ||||
1024 | } | ||||
1025 | elsif ( $atoms->{topic} | ||||
1026 | and Foswiki::Func::topicExists( $atoms->{web}, $atoms->{topic} ) ) | ||||
1027 | { | ||||
1028 | if ( $type eq 'topic' ) { | ||||
1029 | $perfecttype = $type; | ||||
1030 | } | ||||
1031 | $score = 1 + scalar( @{ $atoms->{webpath} } ); | ||||
1032 | } | ||||
1033 | elsif ( $atoms->{web} and Foswiki::Func::webExists( $atoms->{web} ) ) { | ||||
1034 | if ( $type eq 'web' ) { | ||||
1035 | $perfecttype = $type; | ||||
1036 | } | ||||
1037 | $score = scalar( @{ $atoms->{webpath} } ); | ||||
1038 | } | ||||
1039 | elsif ( $atoms->{webpath} ) { | ||||
1040 | ASSERT( scalar( @{ $atoms->{webpath} } ) ) if DEBUG; | ||||
1041 | ASSERT( ref( $atoms->{webpath} ) eq 'ARRAY' ) if DEBUG; | ||||
1042 | my $i = scalar( @{ $atoms->{webpath} } ); | ||||
1043 | my $nAtoms = scalar( @{ $atoms->{webpath} } ); | ||||
1044 | |||||
1045 | while ( $i > 0 and not $score ) { | ||||
1046 | $i -= 1; | ||||
1047 | if ( | ||||
1048 | Foswiki::Func::webExists( | ||||
1049 | join( '/', @{ $atoms->{webpath} }[ 0 .. $i ] ) | ||||
1050 | ) | ||||
1051 | ) | ||||
1052 | { | ||||
1053 | $score = $i + 1; | ||||
1054 | } | ||||
1055 | } | ||||
1056 | } | ||||
1057 | |||||
1058 | return ( $perfecttype, $score ); | ||||
1059 | } | ||||
1060 | |||||
1061 | =begin TML | ||||
1062 | |||||
1063 | ---++ ClassMethod stringify => $string | ||||
1064 | |||||
1065 | Return a string representation of the address. | ||||
1066 | |||||
1067 | The output of =stringify()= is understood by =_parse()=, and vice versa. | ||||
1068 | |||||
1069 | =cut | ||||
1070 | |||||
1071 | sub stringify { | ||||
1072 | my ($this) = @_; | ||||
1073 | |||||
1074 | ASSERT( $this->isValid(), 'valid address' ) if DEBUG; | ||||
1075 | |||||
1076 | # If there's a valid address; and check that we haven't already computed | ||||
1077 | # the stringification before | ||||
1078 | if ( !defined $this->{stringified} ) { | ||||
1079 | if ( $this->{webpath} ) { | ||||
1080 | $this->{stringified} = | ||||
1081 | join( STRINGIFIED_WEB_SEPARATOR, @{ $this->{webpath} } ); | ||||
1082 | if ( $this->{topic} ) { | ||||
1083 | $this->{stringified} .= | ||||
1084 | STRINGIFIED_TOPIC_SEPARATOR . $this->{topic}; | ||||
1085 | if ( $this->{tompath} ) { | ||||
1086 | ASSERT( ref( $this->{tompath} ) eq 'ARRAY' | ||||
1087 | and scalar( @{ $this->{tompath} } ) ) | ||||
1088 | if DEBUG; | ||||
1089 | print STDERR 'tompath: ' | ||||
1090 | . Data::Dumper->Dump( [ $this->{tompath} ] ) | ||||
1091 | if TRACEATTACH; | ||||
1092 | print STDERR 'attachment: ' | ||||
1093 | . Data::Dumper->Dump( [ $this->{attachment} ] ) | ||||
1094 | if TRACEATTACH; | ||||
1095 | ASSERT( | ||||
1096 | $this->{tompath}->[0] ne 'attachment' | ||||
1097 | or not $this->{tompath}->[1] | ||||
1098 | or ( $this->{attachment} | ||||
1099 | and $this->{attachment} eq $this->{tompath}->[1] ) | ||||
1100 | ) if DEBUG; | ||||
1101 | if ( $this->{tompath}->[0] eq 'attachment' | ||||
1102 | and scalar( @{ $this->{tompath} } ) == 2 ) | ||||
1103 | { | ||||
1104 | $this->{stringified} .= '/' . $this->{tompath}->[1]; | ||||
1105 | if ( defined $this->{rev} ) { | ||||
1106 | $this->{stringified} .= '@' . $this->{rev}; | ||||
1107 | } | ||||
1108 | } | ||||
1109 | else { | ||||
1110 | if ( defined $this->{rev} ) { | ||||
1111 | $this->{stringified} .= '@' . $this->{rev}; | ||||
1112 | } | ||||
1113 | $this->{stringified} = '\'' | ||||
1114 | . $this->{stringified} . '\'/' | ||||
1115 | . $this->{tompath}->[0]; | ||||
1116 | if ( $this->{tompath}->[1] ) { | ||||
1117 | my @path = @{ $this->{tompath} }; | ||||
1118 | my $root = shift(@path); | ||||
1119 | |||||
1120 | if ( $root eq 'META' and scalar(@path) ) { | ||||
1121 | $this->{stringified} .= ':' . shift(@path); | ||||
1122 | } | ||||
1123 | if ( scalar(@path) ) { | ||||
1124 | if ( defined $path[0] ) { | ||||
1125 | $this->{stringified} .= '['; | ||||
1126 | if ( ref( $path[0] ) eq 'HASH' ) { | ||||
1127 | my @selectorparts; | ||||
1128 | while ( my ( $key, $value ) = | ||||
1129 | each %{ $path[0] } ) | ||||
1130 | { | ||||
1131 | push( @selectorparts, | ||||
1132 | $key . '=\'' . $value . '\'' ); | ||||
1133 | } | ||||
1134 | $this->{stringified} .= | ||||
1135 | join( ' AND ', @selectorparts ); | ||||
1136 | shift(@path); | ||||
1137 | } | ||||
1138 | else { | ||||
1139 | ASSERT( $path[0] =~ m/^\d+$/ ) if DEBUG; | ||||
1140 | $this->{stringified} .= shift(@path); | ||||
1141 | } | ||||
1142 | $this->{stringified} .= ']'; | ||||
1143 | } | ||||
1144 | else { | ||||
1145 | shift @path; | ||||
1146 | } | ||||
1147 | if ( scalar(@path) ) { | ||||
1148 | ASSERT( scalar(@path) == 1 ) if DEBUG; | ||||
1149 | $this->{stringified} .= '.' . shift(@path); | ||||
1150 | } | ||||
1151 | } | ||||
1152 | ASSERT( not scalar(@path) ) if DEBUG; | ||||
1153 | } | ||||
1154 | } | ||||
1155 | } | ||||
1156 | elsif ( defined $this->{rev} ) { | ||||
1157 | $this->{stringified} .= '@' . $this->{rev}; | ||||
1158 | } | ||||
1159 | } | ||||
1160 | else { | ||||
1161 | $this->{stringified} .= STRINGIFIED_WEB_SEPARATOR; | ||||
1162 | } | ||||
1163 | } | ||||
1164 | else { | ||||
1165 | ASSERT( $this->{root} ); | ||||
1166 | $this->{stringified} = '/'; | ||||
1167 | } | ||||
1168 | } | ||||
1169 | print STDERR "stringify(): $this->{stringified}\n" | ||||
1170 | if TRACE2 and $this->{stringified}; | ||||
1171 | |||||
1172 | return $this->{stringified}; | ||||
1173 | } | ||||
1174 | |||||
1175 | =begin TML | ||||
1176 | |||||
1177 | ---++ EXPERIMENTAL ClassMethod root( [$boolean] ) => $boolean | ||||
1178 | |||||
1179 | * =$boolean= - optional, set the hypothetical Foswiki 'root'. Since all | ||||
1180 | Foswiki resources must exist under the root, a false value here basically | ||||
1181 | means the address object is an undefined/invalid state. | ||||
1182 | |||||
1183 | Get/set root | ||||
1184 | |||||
1185 | <blockquote class="tml">%X% This method (and the =root= attribute generally) | ||||
1186 | may be removed before we release Foswiki 2.0. We would rather use web => '/' | ||||
1187 | </blockquote> | ||||
1188 | |||||
1189 | =cut | ||||
1190 | |||||
1191 | sub root { | ||||
1192 | my ( $this, $root ) = @_; | ||||
1193 | |||||
1194 | if ( scalar(@_) == 2 ) { | ||||
1195 | $this->{root} = $root; | ||||
1196 | $this->_invalidate(); | ||||
1197 | } | ||||
1198 | else { | ||||
1199 | $this->isValid(); | ||||
1200 | } | ||||
1201 | |||||
1202 | return $this->{root}; | ||||
1203 | } | ||||
1204 | |||||
1205 | =begin TML | ||||
1206 | |||||
1207 | ---++ ClassMethod web( [$name] ) => $name | ||||
1208 | |||||
1209 | * =$name= - optional, set a new web name | ||||
1210 | |||||
1211 | Get/set by web string | ||||
1212 | |||||
1213 | =cut | ||||
1214 | |||||
1215 | sub web { | ||||
1216 | my ( $this, $web ) = @_; | ||||
1217 | |||||
1218 | ASSERT( | ||||
1219 | scalar(@_) == 2 | ||||
1220 | or | ||||
1221 | ( defined( $this->{webpath} ) and ref( $this->{webpath} ) eq 'ARRAY' ) | ||||
1222 | ) if DEBUG; | ||||
1223 | if ( scalar(@_) == 2 ) { | ||||
1224 | $this->webpath( [ split( /[\/\.]/, $web ) ] ); | ||||
1225 | } | ||||
1226 | if ( not $this->{web} and defined( $this->{webpath} ) ) { | ||||
1227 | $this->{web} = join( '/', @{ $this->{webpath} } ); | ||||
1228 | } | ||||
1229 | print STDERR "web(): no web part!\n" if TRACE and not $this->{web}; | ||||
1230 | |||||
1231 | return $this->{web}; | ||||
1232 | } | ||||
1233 | |||||
1234 | =begin TML | ||||
1235 | |||||
1236 | ---++ ClassMethod webpath( [\@webpath] ) => \@webpath | ||||
1237 | |||||
1238 | * =\@webpath= - optional, set a new webpath arrayref | ||||
1239 | |||||
1240 | Get/set the webpath arrayref | ||||
1241 | |||||
1242 | =cut | ||||
1243 | |||||
1244 | sub webpath { | ||||
1245 | my ( $this, $webpath ) = @_; | ||||
1246 | |||||
1247 | if ( scalar(@_) == 2 ) { | ||||
1248 | $this->{webpath} = $webpath; | ||||
1249 | $this->_invalidate(); | ||||
1250 | } | ||||
1251 | |||||
1252 | return $this->{webpath}; | ||||
1253 | } | ||||
1254 | |||||
1255 | =begin TML | ||||
1256 | |||||
1257 | ---++ ClassMethod topic( [$name] ) => $name | ||||
1258 | |||||
1259 | * =$name= - optional, set a new topic name | ||||
1260 | |||||
1261 | Get/set the topic name | ||||
1262 | |||||
1263 | =cut | ||||
1264 | |||||
1265 | sub topic { | ||||
1266 | my ( $this, $topic ) = @_; | ||||
1267 | |||||
1268 | if ( scalar(@_) == 2 ) { | ||||
1269 | $this->{topic} = $topic; | ||||
1270 | $this->_invalidate(); | ||||
1271 | ASSERT( $this->isValid() ) if DEBUG; | ||||
1272 | } | ||||
1273 | else { | ||||
1274 | $this->isValid(); | ||||
1275 | } | ||||
1276 | |||||
1277 | return $this->{topic}; | ||||
1278 | } | ||||
1279 | |||||
1280 | =begin TML | ||||
1281 | |||||
1282 | ---++ ClassMethod attachment( [$file] ) => $file | ||||
1283 | |||||
1284 | * =$file= - optional, set a new file attachment name | ||||
1285 | |||||
1286 | Get/set the file attachment name | ||||
1287 | |||||
1288 | =cut | ||||
1289 | |||||
1290 | sub attachment { | ||||
1291 | my ( $this, $attachment ) = @_; | ||||
1292 | |||||
1293 | if ( scalar(@_) == 2 ) { | ||||
1294 | $this->{attachment} = $attachment; | ||||
1295 | $this->{tompath} = [ 'attachment', $attachment ]; | ||||
1296 | $this->_invalidate(); | ||||
1297 | ASSERT( $this->isValid() ) if DEBUG; | ||||
1298 | } | ||||
1299 | else { | ||||
1300 | $this->isValid(); | ||||
1301 | } | ||||
1302 | |||||
1303 | return $this->{attachment}; | ||||
1304 | } | ||||
1305 | |||||
1306 | =begin TML | ||||
1307 | |||||
1308 | ---++ ClassMethod rev( [$rev] ) => $rev | ||||
1309 | |||||
1310 | * =$rev= - optional, set rev number | ||||
1311 | |||||
1312 | Get/set the rev | ||||
1313 | |||||
1314 | =cut | ||||
1315 | |||||
1316 | sub rev { | ||||
1317 | my ( $this, $rev ) = @_; | ||||
1318 | |||||
1319 | if ( scalar(@_) == 2 ) { | ||||
1320 | $this->{rev} = $rev; | ||||
1321 | $this->_invalidate(); | ||||
1322 | ASSERT( $this->isValid() ) if DEBUG; | ||||
1323 | } | ||||
1324 | else { | ||||
1325 | $this->isValid(); | ||||
1326 | } | ||||
1327 | |||||
1328 | return $this->{rev}; | ||||
1329 | } | ||||
1330 | |||||
1331 | =begin TML | ||||
1332 | |||||
1333 | ---++ ClassMethod tompath( [\@tompath] ) => \@tompath | ||||
1334 | |||||
1335 | * =\@tompath= - optional, =tompath= specification into the containing topic. | ||||
1336 | The first =$tompath->[0]= element in the array should be one of the following | ||||
1337 | * ='attachment'=: =$tompath->[1]= should be a string, Eg. ='Attachment.pdf'=. | ||||
1338 | * ='META'=: =$tompath->[1..3]= identify which =META:<type>= or member | ||||
1339 | or member key is being addressed: | ||||
1340 | * =$tompath->[1]= contains the =META:<type>=, Eg. ='FIELD'= | ||||
1341 | * =$tompath->[2]= contains a selector to identify a member of the type: | ||||
1342 | * =undef=, for singleton types (such as ='TOPICINFO'=) | ||||
1343 | * integer array index | ||||
1344 | * hashref =key => 'value'= pairs, Eg. ={name => 'Colour'}=. | ||||
1345 | ={name => 'Colour', form => 'MyForm'}= is also supported. | ||||
1346 | * =$tompath->[3]= contains the name of a key on the selected member, | ||||
1347 | Eg. ='value'= | ||||
1348 | * ='SECTION'=: =$tompath->[1]= should be a hashref, Eg. | ||||
1349 | ={name => 'mysection', type => 'include'}= | ||||
1350 | * ='text'=: addresses the topic text | ||||
1351 | |||||
1352 | Get/set the tompath into a topic | ||||
1353 | |||||
1354 | =cut | ||||
1355 | |||||
1356 | sub tompath { | ||||
1357 | my ( $this, $tompath ) = @_; | ||||
1358 | |||||
1359 | if ( scalar(@_) == 2 ) { | ||||
1360 | $this->{tompath} = $tompath; | ||||
1361 | $this->_invalidate(); | ||||
1362 | ASSERT( | ||||
1363 | not defined $tompath | ||||
1364 | or ( defined $tompath | ||||
1365 | and ref($tompath) eq 'ARRAY' | ||||
1366 | and scalar( @{$tompath} ) ) | ||||
1367 | ) if DEBUG; | ||||
1368 | } | ||||
1369 | else { | ||||
1370 | $this->isValid(); | ||||
1371 | } | ||||
1372 | |||||
1373 | return $this->{tompath}; | ||||
1374 | } | ||||
1375 | |||||
1376 | =begin TML | ||||
1377 | |||||
1378 | ---++ ClassMethod type() => $resourcetype | ||||
1379 | |||||
1380 | Returns the resource type name. | ||||
1381 | |||||
1382 | =cut | ||||
1383 | |||||
1384 | sub type { | ||||
1385 | my ($this) = @_; | ||||
1386 | |||||
1387 | return $this->isValid(); | ||||
1388 | } | ||||
1389 | |||||
1390 | =begin TML | ||||
1391 | |||||
1392 | ---++ ClassMethod isA([$resourcetype]) => $boolean | ||||
1393 | |||||
1394 | Returns true if the address points to a resource of the specified type. | ||||
1395 | |||||
1396 | =cut | ||||
1397 | |||||
1398 | sub isA { | ||||
1399 | my ( $this, $resourcetype ) = @_; | ||||
1400 | my $result; | ||||
1401 | |||||
1402 | if ( $resourcetype and $this->isValid() ) { | ||||
1403 | $result = $this->{isA}->{$resourcetype}; | ||||
1404 | } | ||||
1405 | |||||
1406 | return $result; | ||||
1407 | } | ||||
1408 | |||||
1409 | =begin TML | ||||
1410 | |||||
1411 | ---++ ClassMethod isValid() => $resourcetype | ||||
1412 | |||||
1413 | Returns true if the instance addresses a resource which is one of the following | ||||
1414 | types: | ||||
1415 | * webpath, Eg. =Web/SubWeb/= | ||||
1416 | * topic, Eg. =Web/SubWeb.Topic= | ||||
1417 | * attachment, Eg. =Web/SubWeb.Topic/Attachment.pdf= | ||||
1418 | * attachments , Eg. ='Web/SubWeb.Topic/attachment'= | ||||
1419 | * meta, Eg. ='Web/SubWeb.Topic'/META= | ||||
1420 | * metatype, Eg. ='Web/SubWeb.Topic'/META:FIELD= | ||||
1421 | * metamember, Eg. ='Web/SubWeb.Topic'/META:FIELD[name='Colour']= or ='Web/SubWeb.Topic'/META:FIELD[0]= | ||||
1422 | * metakey, Eg. ='Web/SubWeb.Topic'/META:FIELD[name='Colour'].value= or ='Web/SubWeb.Topic'/META:FIELD[0].value= | ||||
1423 | * section, Eg. ='Web/SubWeb.Topic'/SECTION[name='something']= | ||||
1424 | * sections, Eg. ='Web/SubWeb.Topic'/SECTION= | ||||
1425 | * text, Eg. ='Web/SubWeb.Topic'/text= | ||||
1426 | |||||
1427 | =cut | ||||
1428 | |||||
1429 | sub isValid { | ||||
1430 | my ($this) = @_; | ||||
1431 | |||||
1432 | if ( not defined $this->{isA} ) { | ||||
1433 | print STDERR "isValid(): we don't know what we are (yet)\n" | ||||
1434 | if TRACEVALID; | ||||
1435 | if ( $this->{topic} ) { | ||||
1436 | $this->_trace_have_valid('topic') if TRACEVALID; | ||||
1437 | ASSERT( $this->{topic} !~ /[\/\.]/, | ||||
1438 | "topic '$this->{topic}' contains no path separators" ) | ||||
1439 | if DEBUG; | ||||
1440 | if ( $this->{webpath} ) { | ||||
1441 | $this->_trace_have_valid('webpath') if TRACEVALID; | ||||
1442 | if ( $this->{attachment} ) { | ||||
1443 | $this->_trace_is_valid('attachment') if TRACEVALID; | ||||
1444 | $this->{type} = 'attachment'; | ||||
1445 | } | ||||
1446 | elsif ( $this->{tompath} ) { | ||||
1447 | ASSERT( ref( $this->{tompath} ) eq 'ARRAY' | ||||
1448 | and scalar( @{ $this->{tompath} } ) ) | ||||
1449 | if DEBUG; | ||||
1450 | ASSERT( | ||||
1451 | not( $this->{topmath}->[0] | ||||
1452 | and $this->{topmath}->[0] eq 'attachment' ) | ||||
1453 | ) if DEBUG; | ||||
1454 | ASSERT( $pathtypes{ $this->{tompath}->[0] } ) if DEBUG; | ||||
1455 | $this->{type} = | ||||
1456 | $pathtypes{ $this->{tompath}->[0] } | ||||
1457 | ->{ scalar( @{ $this->{tompath} } ) }; | ||||
1458 | $this->_trace_is_valid( $this->{type} ) if TRACEVALID; | ||||
1459 | } | ||||
1460 | else { | ||||
1461 | ASSERT( not defined $this->{tompath} ) if DEBUG; | ||||
1462 | $this->_trace_is_valid('topic') if TRACEVALID; | ||||
1463 | $this->{type} = 'topic'; | ||||
1464 | } | ||||
1465 | } | ||||
1466 | } | ||||
1467 | elsif ( $this->{webpath} | ||||
1468 | and not defined $this->{tompath} ) | ||||
1469 | { | ||||
1470 | $this->_trace_is_valid('webpath') if TRACEVALID; | ||||
1471 | $this->{type} = 'webpath'; | ||||
1472 | } | ||||
1473 | elsif ( $this->{root} ) { | ||||
1474 | $this->_trace_is_valid('root') if TRACEVALID; | ||||
1475 | $this->{type} = 'root'; | ||||
1476 | } | ||||
1477 | else { | ||||
1478 | $this->{type} = undef; | ||||
1479 | } | ||||
1480 | if ( $this->{type} ) { | ||||
1481 | $this->{isA} = { $this->{type} => 1 }; | ||||
1482 | $this->{root} = 1; | ||||
1483 | } | ||||
1484 | else { | ||||
1485 | print STDERR "isValid(): INVALID: " . $this->_trace_stringify($this) | ||||
1486 | if TRACEVALID; | ||||
1487 | $this->{isA} = {}; | ||||
1488 | } | ||||
1489 | ASSERT( | ||||
1490 | ( !defined $this->{rev} || $this->{rev} =~ m/^[-\+]?\d+$/ ), | ||||
1491 | "rev '" | ||||
1492 | . ( defined $this->{rev} ? $this->{rev} : 'undef' ) | ||||
1493 | . "' is numeric" | ||||
1494 | ) if DEBUG; | ||||
1495 | } | ||||
1496 | print STDERR "isValid(): final type is: $this->{type}\n" if TRACEVALID; | ||||
1497 | |||||
1498 | return $this->{type}; | ||||
1499 | } | ||||
1500 | |||||
1501 | sub _trace_stringify { | ||||
1502 | my ( $this, $thing ) = @_; | ||||
1503 | |||||
1504 | if ( ref($thing) ) { | ||||
1505 | require Data::Dumper; | ||||
1506 | $thing = Data::Dumper->Dump( [$thing] ); | ||||
1507 | } | ||||
1508 | |||||
1509 | return $thing; | ||||
1510 | } | ||||
1511 | |||||
1512 | sub _trace_have_valid { | ||||
1513 | my ( $this, $what ) = @_; | ||||
1514 | |||||
1515 | print STDERR "isValid(): have $what => '" | ||||
1516 | . $this->_trace_stringify( $this->{$what} ) . "'\n" | ||||
1517 | if TRACEVALID; | ||||
1518 | |||||
1519 | return; | ||||
1520 | } | ||||
1521 | |||||
1522 | sub _trace_is_valid { | ||||
1523 | my ( $this, $what ) = @_; | ||||
1524 | |||||
1525 | print STDERR "isValid(): type is $what => '" | ||||
1526 | . $this->_trace_stringify( $this->{$what} ) . "'\n" | ||||
1527 | if TRACEVALID; | ||||
1528 | |||||
1529 | return; | ||||
1530 | } | ||||
1531 | |||||
1532 | # Internally, this is called so that the next isValid() call will re-evaluate | ||||
1533 | # identity and validity of the instance; also, if any of the setters are used, | ||||
1534 | # invalidates the cached stringify value | ||||
1535 | sub _invalidate { | ||||
1536 | my ($this) = @_; | ||||
1537 | |||||
1538 | $this->{stringified} = undef; | ||||
1539 | $this->{isA} = undef; | ||||
1540 | |||||
1541 | return; | ||||
1542 | } | ||||
1543 | |||||
1544 | =begin TML | ||||
1545 | |||||
1546 | ---++ ClassMethod equiv ( $otherAddr ) => $boolean | ||||
1547 | |||||
1548 | Return true if this address resolves to the same resource as =$otherAddr= | ||||
1549 | |||||
1550 | =cut | ||||
1551 | |||||
1552 | sub equiv { | ||||
1553 | my ( $this, $other ) = @_; | ||||
1554 | my $nwebpath; | ||||
1555 | my $equal = 0; | ||||
1556 | my $thistype = $this->type(); | ||||
1557 | my $othertype = $other->type(); | ||||
1558 | |||||
1559 | # Same type? | ||||
1560 | if ( $thistype and $othertype and $thistype eq $othertype ) { | ||||
1561 | |||||
1562 | # Confirm the ->type() is sane | ||||
1563 | ASSERT( | ||||
1564 | ( not defined $this->{tompath} and not defined $other->{tompath} ) | ||||
1565 | or ( defined $this->{tompath} | ||||
1566 | and defined $other->{tompath} | ||||
1567 | and ref( $this->{tompath} ) eq 'ARRAY' | ||||
1568 | and ref( $other->{tompath} ) eq 'ARRAY' | ||||
1569 | and scalar( @{ $this->{tompath} } ) | ||||
1570 | and scalar( @{ $other->{tompath} } ) | ||||
1571 | and scalar( @{ $this->{tompath} } ) == | ||||
1572 | scalar( @{ $other->{tompath} } ) ) | ||||
1573 | ) if DEBUG; | ||||
1574 | ASSERT( | ||||
1575 | ( not defined $this->{tompath} and not defined $other->{tompath} ) | ||||
1576 | or ( defined $this->{tompath} | ||||
1577 | and defined $other->{tompath} | ||||
1578 | and $this->{tompath}->[0] eq $other->{tompath}->[0] ) | ||||
1579 | ) if DEBUG; | ||||
1580 | if ( $this->{webpath} ) { | ||||
1581 | if ( $this->_eq( $this->{webpath}, $other->{webpath} ) ) { | ||||
1582 | if ( $this->_eq( $this->{topic}, $other->{topic} ) ) { | ||||
1583 | if ( $this->_eq( $this->{tompath}, $other->{tompath} ) ) { | ||||
1584 | $equal = 1; | ||||
1585 | } | ||||
1586 | elsif (TRACE) { | ||||
1587 | print STDERR "equiv(): tompaths weren't equal\n"; | ||||
1588 | } | ||||
1589 | } | ||||
1590 | elsif (TRACE) { | ||||
1591 | print STDERR "equiv(): topics weren't equal\n"; | ||||
1592 | } | ||||
1593 | } | ||||
1594 | elsif (TRACE) { | ||||
1595 | print STDERR "equiv(): webpath wasn't equal\n"; | ||||
1596 | } | ||||
1597 | } | ||||
1598 | elsif ( $this->{root} ) { | ||||
1599 | if ( $other->{root} ) { | ||||
1600 | $equal = 1; | ||||
1601 | } | ||||
1602 | elsif (TRACE) { | ||||
1603 | print STDERR "equiv(): roots weren't equal\n"; | ||||
1604 | } | ||||
1605 | } | ||||
1606 | } | ||||
1607 | elsif (TRACE) { | ||||
1608 | print STDERR "equiv(): types weren't equal\n"; | ||||
1609 | } | ||||
1610 | if ( not $equal ) { | ||||
1611 | print STDERR "equiv(): NOT equal " | ||||
1612 | . Data::Dumper->Dump( [$this] ) . " vs " | ||||
1613 | . Data::Dumper->Dump( [$other] ) . "\n" | ||||
1614 | if TRACE; | ||||
1615 | } | ||||
1616 | |||||
1617 | return $equal; | ||||
1618 | } | ||||
1619 | |||||
1620 | sub _eq { | ||||
1621 | my ( $this, $a, $b ) = @_; | ||||
1622 | my $equal = 1; | ||||
1623 | my $refA = ref($a); | ||||
1624 | my $refB = ref($b); | ||||
1625 | |||||
1626 | if ($refA) { | ||||
1627 | if ( $refB and $refA eq $refB ) { | ||||
1628 | if ( $refA eq 'ARRAY' ) { | ||||
1629 | my $n = scalar( @{$a} ); | ||||
1630 | |||||
1631 | if ( $n == scalar( @{$b} ) ) { | ||||
1632 | my $i = 0; | ||||
1633 | |||||
1634 | while ( $equal and $i < $n ) { | ||||
1635 | $equal = $this->_eq( $a->[$i], $b->[$i] ); | ||||
1636 | $i += 1; | ||||
1637 | } | ||||
1638 | } | ||||
1639 | else { | ||||
1640 | $equal = 0; | ||||
1641 | } | ||||
1642 | } | ||||
1643 | elsif ( $refB eq 'HASH' ) { | ||||
1644 | my @keys = keys %{$a}; | ||||
1645 | my $n = scalar(@keys); | ||||
1646 | |||||
1647 | if ( $n == scalar( keys %{$b} ) ) { | ||||
1648 | my $i = 0; | ||||
1649 | |||||
1650 | while ( $equal and $i < $n ) { | ||||
1651 | if ( exists $b->{ $keys[$i] } ) { | ||||
1652 | $equal = | ||||
1653 | $this->_eq( $a->{ $keys[$i] }, | ||||
1654 | $b->{ $keys[$i] } ); | ||||
1655 | $i += 1; | ||||
1656 | } | ||||
1657 | else { | ||||
1658 | $equal = 0; | ||||
1659 | } | ||||
1660 | } | ||||
1661 | } | ||||
1662 | } | ||||
1663 | } | ||||
1664 | } | ||||
1665 | elsif ($refB | ||||
1666 | or ( defined $a and not defined $b or not defined $a and defined $b ) | ||||
1667 | or ( defined $a and defined $b and $a ne $b ) ) | ||||
1668 | { | ||||
1669 | $equal = 0; | ||||
1670 | } | ||||
1671 | |||||
1672 | return $equal; | ||||
1673 | } | ||||
1674 | |||||
1675 | 1 | 22µs | 1; | ||
1676 | __END__ |