Dylan mode

​x
 
1
Module:       locators-internals
2
Synopsis:     Abstract modeling of locations
3
Author:       Andy Armstrong
4
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
5
              All rights reserved.
6
License:      See License.txt in this distribution for details.
7
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND
8
​
9
define open generic locator-server
10
    (locator :: <locator>) => (server :: false-or(<server-locator>));
11
define open generic locator-host
12
    (locator :: <locator>) => (host :: false-or(<string>));
13
define open generic locator-volume
14
    (locator :: <locator>) => (volume :: false-or(<string>));
15
define open generic locator-directory
16
    (locator :: <locator>) => (directory :: false-or(<directory-locator>));
17
define open generic locator-relative?
18
    (locator :: <locator>) => (relative? :: <boolean>);
19
define open generic locator-path
20
    (locator :: <locator>) => (path :: <sequence>);
21
define open generic locator-base
22
    (locator :: <locator>) => (base :: false-or(<string>));
23
define open generic locator-extension
24
    (locator :: <locator>) => (extension :: false-or(<string>));
25
​
26
/// Locator classes
27
​
28
define open abstract class <directory-locator> (<physical-locator>)
29
end class <directory-locator>;
30
​
31
define open abstract class <file-locator> (<physical-locator>)
32
end class <file-locator>;
33
​
34
define method as
35
    (class == <directory-locator>, string :: <string>)
36
 => (locator :: <directory-locator>)
37
  as(<native-directory-locator>, string)
38
end method as;
39
​
40
define method make
41
    (class == <directory-locator>,
42
     #key server :: false-or(<server-locator>) = #f,
43
          path :: <sequence> = #[],
44
          relative? :: <boolean> = #f,
45
          name :: false-or(<string>) = #f)
46
 => (locator :: <directory-locator>)
47
  make(<native-directory-locator>,
48
       server:    server,
49
       path:      path,
50
       relative?: relative?,
51
       name:      name)
52
end method make;
53
​
54
define method as
55
    (class == <file-locator>, string :: <string>)
56
 => (locator :: <file-locator>)
57
  as(<native-file-locator>, string)
58
end method as;
59
​
60
define method make
61
    (class == <file-locator>,
62
     #key directory :: false-or(<directory-locator>) = #f,
63
          base :: false-or(<string>) = #f,
64
          extension :: false-or(<string>) = #f,
65
          name :: false-or(<string>) = #f)
66
 => (locator :: <file-locator>)
67
  make(<native-file-locator>,
68
       directory: directory,
69
       base:      base,
70
       extension: extension,
71
       name:      name)
72
end method make;
73
​
74
/// Locator coercion
75
​
76
//---*** andrewa: This caching scheme doesn't work yet, so disable it.
77
define constant $cache-locators?        = #f;
78
define constant $cache-locator-strings? = #f;
79
​
80
define constant $locator-to-string-cache = make(<object-table>, weak: #"key");
81
define constant $string-to-locator-cache = make(<string-table>, weak: #"value");
82
​
83
define open generic locator-as-string
84
    (class :: subclass(<string>), locator :: <locator>)
85
 => (string :: <string>);
86
​
87
define open generic string-as-locator
88
    (class :: subclass(<locator>), string :: <string>)
89
 => (locator :: <locator>);
90
​
91
define sealed sideways method as
92
    (class :: subclass(<string>), locator :: <locator>)
93
 => (string :: <string>)
94
  let string = element($locator-to-string-cache, locator, default: #f);
95
  if (string)
96
    as(class, string)
97
  else
98
    let string = locator-as-string(class, locator);
99
    if ($cache-locator-strings?)
100
      element($locator-to-string-cache, locator) := string;
101
    else
102
      string
103
    end
104
  end
105
end method as;
106
​
107
define sealed sideways method as
108
    (class :: subclass(<locator>), string :: <string>)
109
 => (locator :: <locator>)
110
  let locator = element($string-to-locator-cache, string, default: #f);
111
  if (instance?(locator, class))
112
    locator
113
  else
114
    let locator = string-as-locator(class, string);
115
    if ($cache-locators?)
116
      element($string-to-locator-cache, string) := locator;
117
    else
118
      locator
119
    end
120
  end
121
end method as;
122
​
123
/// Locator conditions
124
​
125
define class <locator-error> (<format-string-condition>, <error>)
126
end class <locator-error>;
127
​
128
define function locator-error
129
    (format-string :: <string>, #rest format-arguments)
130
  error(make(<locator-error>,
131
             format-string:    format-string,
132
             format-arguments: format-arguments))
133
end function locator-error;
134
​
135
/// Useful locator protocols
136
​
137
define open generic locator-test
138
    (locator :: <directory-locator>) => (test :: <function>);
139
​
140
define method locator-test
141
    (locator :: <directory-locator>) => (test :: <function>)
142
  \=
143
end method locator-test;
144
​
145
define open generic locator-might-have-links?
146
    (locator :: <directory-locator>) => (links? :: <boolean>);
147
​
148
define method locator-might-have-links?
149
    (locator :: <directory-locator>) => (links? :: singleton(#f))
150
  #f
151
end method locator-might-have-links?;
152
​
153
define method locator-relative?
154
    (locator :: <file-locator>) => (relative? :: <boolean>)
155
  let directory = locator.locator-directory;
156
  ~directory | directory.locator-relative?
157
end method locator-relative?;
158
​
159
define method current-directory-locator?
160
    (locator :: <directory-locator>) => (current-directory? :: <boolean>)
161
  locator.locator-relative?
162
    & locator.locator-path = #[#"self"]
163
end method current-directory-locator?;
164
​
165
define method locator-directory
166
    (locator :: <directory-locator>) => (parent :: false-or(<directory-locator>))
167
  let path = locator.locator-path;
168
  unless (empty?(path))
169
    make(object-class(locator),
170
         server:    locator.locator-server,
171
         path:      copy-sequence(path, end: path.size - 1),
172
         relative?: locator.locator-relative?)
173
  end
174
end method locator-directory;
175
​
176
/// Simplify locator
177
​
178
define open generic simplify-locator
179
    (locator :: <physical-locator>)
180
 => (simplified-locator :: <physical-locator>);
181
​
182
define method simplify-locator
183
    (locator :: <directory-locator>)
184
 => (simplified-locator :: <directory-locator>)
185
  let path = locator.locator-path;
186
  let relative? = locator.locator-relative?;
187
  let resolve-parent? = ~locator.locator-might-have-links?;
188
  let simplified-path
189
    = simplify-path(path,
190
                    resolve-parent?: resolve-parent?,
191
                    relative?: relative?);
192
  if (path ~= simplified-path)
193
    make(object-class(locator),
194
         server:    locator.locator-server,
195
         path:      simplified-path,
196
         relative?: locator.locator-relative?)
197
  else
198
    locator
199
  end
200
end method simplify-locator;
201
​
202
define method simplify-locator
203
    (locator :: <file-locator>) => (simplified-locator :: <file-locator>)
204
  let directory = locator.locator-directory;
205
  let simplified-directory = directory & simplify-locator(directory);
206
  if (directory ~= simplified-directory)
207
    make(object-class(locator),
208
         directory: simplified-directory,
209
         base:      locator.locator-base,
210
         extension: locator.locator-extension)
211
  else
212
    locator
213
  end
214
end method simplify-locator;
215
​
216
/// Subdirectory locator
217
​
218
define open generic subdirectory-locator
219
    (locator :: <directory-locator>, #rest sub-path)
220
 => (subdirectory :: <directory-locator>);
221
​
222
define method subdirectory-locator
223
    (locator :: <directory-locator>, #rest sub-path)
224
 => (subdirectory :: <directory-locator>)
225
  let old-path = locator.locator-path;
226
  let new-path = concatenate-as(<simple-object-vector>, old-path, sub-path);
227
  make(object-class(locator),
228
       server:    locator.locator-server,
229
       path:      new-path,
230
       relative?: locator.locator-relative?)
231
end method subdirectory-locator;
232
​
233
/// Relative locator
234
​
235
define open generic relative-locator
236
    (locator :: <physical-locator>, from-locator :: <physical-locator>)
237
 => (relative-locator :: <physical-locator>);
238
​
239
define method relative-locator
240
    (locator :: <directory-locator>, from-locator :: <directory-locator>)
241
 => (relative-locator :: <directory-locator>)
242
  let path = locator.locator-path;
243
  let from-path = from-locator.locator-path;
244
  case
245
    ~locator.locator-relative? & from-locator.locator-relative? =>
246
      locator-error
247
        ("Cannot find relative path of absolute locator %= from relative locator %=",
248
         locator, from-locator);
249
    locator.locator-server ~= from-locator.locator-server =>
250
      locator;
251
    path = from-path =>
252
      make(object-class(locator),
253
           path: vector(#"self"),
254
           relative?: #t);
255
    otherwise =>
256
      make(object-class(locator),
257
           path: relative-path(path, from-path, test: locator.locator-test),
258
           relative?: #t);
259
  end
260
end method relative-locator;
261
​
262
define method relative-locator
263
    (locator :: <file-locator>, from-directory :: <directory-locator>)
264
 => (relative-locator :: <file-locator>)
265
  let directory = locator.locator-directory;
266
  let relative-directory = directory & relative-locator(directory, from-directory);
267
  if (relative-directory ~= directory)
268
    simplify-locator
269
      (make(object-class(locator),
270
            directory: relative-directory,
271
            base:      locator.locator-base,
272
            extension: locator.locator-extension))
273
  else
274
    locator
275
  end
276
end method relative-locator;
277
​
278
define method relative-locator
279
    (locator :: <physical-locator>, from-locator :: <file-locator>)
280
 => (relative-locator :: <physical-locator>)
281
  let from-directory = from-locator.locator-directory;
282
  case
283
    from-directory =>
284
      relative-locator(locator, from-directory);
285
    ~locator.locator-relative? =>
286
      locator-error
287
        ("Cannot find relative path of absolute locator %= from relative locator %=",
288
         locator, from-locator);
289
    otherwise =>
290
      locator;
291
  end
292
end method relative-locator;
293
​
294
/// Merge locators
295
​
296
define open generic merge-locators
297
    (locator :: <physical-locator>, from-locator :: <physical-locator>)
298
 => (merged-locator :: <physical-locator>);
299
​
300
/// Merge locators
301
​
302
define method merge-locators
303
    (locator :: <directory-locator>, from-locator :: <directory-locator>)
304
 => (merged-locator :: <directory-locator>)
305
  if (locator.locator-relative?)
306
    let path = concatenate(from-locator.locator-path, locator.locator-path);
307
    simplify-locator
308
      (make(object-class(locator),
309
            server:    from-locator.locator-server,
310
            path:      path,
311
            relative?: from-locator.locator-relative?))
312
  else
313
    locator
314
  end
315
end method merge-locators;
316
​
317
define method merge-locators
318
    (locator :: <file-locator>, from-locator :: <directory-locator>)
319
 => (merged-locator :: <file-locator>)
320
  let directory = locator.locator-directory;
321
  let merged-directory
322
    = if (directory)
323
        merge-locators(directory, from-locator)
324
      else
325
        simplify-locator(from-locator)
326
      end;
327
  if (merged-directory ~= directory)
328
    make(object-class(locator),
329
         directory: merged-directory,
330
         base:      locator.locator-base,
331
         extension: locator.locator-extension)
332
  else
333
    locator
334
  end
335
end method merge-locators;
336
​
337
define method merge-locators
338
    (locator :: <physical-locator>, from-locator :: <file-locator>)
339
 => (merged-locator :: <physical-locator>)
340
  let from-directory = from-locator.locator-directory;
341
  if (from-directory)
342
    merge-locators(locator, from-directory)
343
  else
344
    locator
345
  end
346
end method merge-locators;
347
​
348
/// Locator protocols
349
​
350
define sideways method supports-open-locator?
351
    (locator :: <file-locator>) => (openable? :: <boolean>)
352
  ~locator.locator-relative?
353
end method supports-open-locator?;
354
​
355
define sideways method open-locator
356
    (locator :: <file-locator>, #rest keywords, #key, #all-keys)
357
 => (stream :: <stream>)
358
  apply(open-file-stream, locator, keywords)
359
end method open-locator;
360
​

MIME types defined: text/x-dylan.