~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/pathname.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2007-04-09 11:51:51 UTC
  • mfrom: (1.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070409115151-ql8cr0kalzx1jmla
Tags: 0.9i-20070324-2
Upload to unstable. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
21
21
*/
22
22
 
23
23
#include <ecl/ecl.h>
 
24
#include <limits.h>
24
25
#include <string.h>
25
26
#include <ctype.h>
26
 
#ifdef _MSC_VER
27
 
#define MAXPATHLEN 512
28
 
#endif
29
 
#ifndef MAXPATHLEN
30
 
# ifdef PATH_MAX
31
 
#   define MAXPATHLEN PATH_MAX
32
 
# else
33
 
#   error "Either MAXPATHLEN or PATH_MAX should be defined"
34
 
# endif
35
 
#endif
36
27
 
37
28
typedef int (*delim_fn)(int);
38
29
 
39
 
static cl_object
40
 
ensure_simple_base_string(cl_object s)
 
30
static void
 
31
push_substring(cl_object buffer, cl_object string, cl_index start, cl_index end)
41
32
{
42
 
        switch (type_of(s)) {
43
 
#ifdef ECL_UNICODE
44
 
        case t_string:
45
 
#endif
46
 
        case t_base_string:
47
 
                return si_copy_to_simple_base_string(s);
48
 
        default:
49
 
                return s;
 
33
        string = cl_string(string);
 
34
        while (start < end) {
 
35
                ecl_string_push_extend(buffer, ecl_char(string, start));
 
36
                start++;
50
37
        }
51
38
}
52
39
 
 
40
static void
 
41
push_string(cl_object buffer, cl_object string)
 
42
{
 
43
        push_substring(buffer, string, 0, ecl_length(string));
 
44
}
 
45
 
53
46
static cl_object
54
47
destructively_check_directory(cl_object directory, bool logical)
55
48
{
66
59
        if (CAR(directory) != @':absolute'  && CAR(directory) != @':relative')
67
60
                return Cnil;
68
61
 BEGIN:
69
 
        for (i=0, ptr=directory; !endp(ptr); ptr = CDR(ptr), i++) {
 
62
        for (i=0, ptr=directory; !ecl_endp(ptr); ptr = CDR(ptr), i++) {
70
63
                cl_object item = CAR(ptr);
71
64
                if (item == @':back') {
72
65
                        if (i == 0)
73
66
                                return @':error';
74
 
                        item = nth(i-1, directory);
 
67
                        item = ecl_nth(i-1, directory);
75
68
                        if (item == @':absolute' || item == @':wild-inferiors')
76
69
                                return @':error';
77
 
                        if (i > 2)
78
 
                                CDR(nthcdr(i-2, directory)) = CDR(ptr);
79
 
                } if (item == @':up') {
 
70
                        if (i >= 2)
 
71
                                CDR(ecl_nthcdr(i-2, directory)) = CDR(ptr);
 
72
                } else if (item == @':up') {
80
73
                        if (i == 0)
81
74
                                return @':error';
82
 
                        item = nth(i-1, directory);
 
75
                        item = ecl_nth(i-1, directory);
83
76
                        if (item == @':absolute' || item == @':wild-inferiors')
84
77
                                return @':error';
85
78
                } else if (item == @':relative' || item == @':absolute') {
86
79
                        if (i > 0)
87
80
                                return @':error';
88
 
                } else if (type_of(item) == t_base_string) {
89
 
                        CAR(ptr) = si_copy_to_simple_base_string(item);
 
81
                } else if (ecl_stringp(item)) {
 
82
                        cl_index l = ecl_length(item);
 
83
#ifdef ECL_UNICODE
 
84
                        if (ecl_fits_in_base_string(item)) {
 
85
                                item = si_copy_to_simple_base_string(item);
 
86
                        } else
 
87
#endif
 
88
                                item = cl_copy_seq(item);
 
89
                        CAR(ptr) = item;
90
90
                        if (logical)
91
91
                                continue;
92
 
                        if (strcmp(item->base_string.self,".")==0) {
93
 
                                if (i == 0)
94
 
                                        return @':error';
95
 
                                CDR(nthcdr(i-1, directory)) = CDR(ptr);
96
 
                        } else if (strcmp(item->base_string.self,"..") == 0) {
97
 
                                CAR(directory) = @':back';
98
 
                                goto BEGIN;
 
92
                        if (l && ecl_char(item,0) == '.') {
 
93
                                if (l == 1) {
 
94
                                        /* Single dot */
 
95
                                        if (i == 0)
 
96
                                                return @':error';
 
97
                                        CDR(ecl_nthcdr(i-1, directory)) = CDR(ptr);
 
98
                                } else if (l == 2 && ecl_char(item,1) == '.') {
 
99
                                        CAR(directory) = @':back';
 
100
                                        goto BEGIN;
 
101
                                }
99
102
                        }
100
103
                } else if (item != @':wild' && item != @':wild-inferiors') {
101
104
                        return @':error';
105
108
}
106
109
 
107
110
cl_object
108
 
make_pathname(cl_object host, cl_object device, cl_object directory,
109
 
              cl_object name, cl_object type, cl_object version)
 
111
ecl_make_pathname(cl_object host, cl_object device, cl_object directory,
 
112
                  cl_object name, cl_object type, cl_object version)
110
113
{
111
114
        cl_object x, p, component;
112
115
 
113
116
        p = cl_alloc_object(t_pathname);
114
 
        if (type_of(host) == t_base_string)
115
 
                p->pathname.logical = logical_hostname_p(host);
 
117
        if (ecl_stringp(host))
 
118
                p->pathname.logical = ecl_logical_hostname_p(host);
116
119
        else if (host == Cnil)
117
120
                p->pathname.logical = FALSE;
118
121
        else {
121
124
                goto ERROR;
122
125
        }
123
126
        if (device != Cnil && device != @':unspecific' &&
124
 
            !(!p->pathname.logical && type_of(device) == t_base_string)) {
 
127
            !(!p->pathname.logical && ecl_stringp(device))) {
125
128
                x = device;
126
129
                component = @':device';
127
130
                goto ERROR;
128
131
        }
129
 
        if (name != Cnil && name != @':wild' && type_of(name) != t_base_string) {
 
132
        if (name != Cnil && name != @':wild' && !ecl_stringp(name)) {
130
133
                x = name;
131
134
                component = @':name';
132
135
                goto ERROR;
133
136
        }
134
 
        if (type != Cnil && type != @':wild' && type_of(type) != t_base_string) {
 
137
        if (type != Cnil && type != @':wild' && !ecl_stringp(type)) {
135
138
                x = type;
136
139
                component = @':type';
137
140
                goto ERROR;
144
147
        ERROR:  FEerror("~s is not a valid pathname-~a component", 2, x, component);
145
148
        }
146
149
        switch (type_of(directory)) {
 
150
#ifdef ECL_UNICODE
 
151
        case t_string:
 
152
#endif
147
153
        case t_base_string:
148
154
                directory = cl_list(2, @':absolute', directory);
149
155
                break;
164
170
                component = @':directory';
165
171
                goto ERROR;
166
172
        }
167
 
        p->pathname.host      = ensure_simple_base_string(host);
168
 
        p->pathname.device    = ensure_simple_base_string(device);
 
173
        p->pathname.host      = host;
 
174
        p->pathname.device    = device;
169
175
        p->pathname.directory = directory;
170
 
        p->pathname.name      = ensure_simple_base_string(name);
171
 
        p->pathname.type      = ensure_simple_base_string(type);
172
 
        p->pathname.version   = ensure_simple_base_string(version);
173
 
        if (destructively_check_directory(directory, 1) == @':error') {
 
176
        p->pathname.name      = name;
 
177
        p->pathname.type      = type;
 
178
        p->pathname.version   = version;
 
179
        if (destructively_check_directory(directory, p->pathname.logical) == @':error') {
174
180
                cl_error(3, @'file-error', @':pathname', p);
175
181
        }
176
182
        return(p);
182
188
        cl_object head, prefix;
183
189
 
184
190
        /* INV: pathname is relative */
185
 
        if (endp(directory))
 
191
        if (ecl_endp(directory))
186
192
                goto RET;
187
193
        head = CADR(directory);
188
 
        if (type_of(head) != t_base_string)
189
 
                goto RET;
190
 
        if (head->base_string.fillp == 0 || head->base_string.self[0] != '~')
191
 
                goto RET;
192
 
        prefix = homedir_pathname(head)->pathname.directory;
193
 
        directory = append(prefix, CDDR(directory));
 
194
        if (!ecl_stringp(head))
 
195
                goto RET;
 
196
        if (ecl_length(head) == 0 || ecl_char(head,0) != '~')
 
197
                goto RET;
 
198
        prefix = ecl_homedir_pathname(head)->pathname.directory;
 
199
        directory = ecl_append(prefix, CDDR(directory));
194
200
 RET:
195
201
        return directory;
196
202
}
199
205
#define WORD_ALLOW_ASTERISK  2
200
206
#define WORD_EMPTY_IS_NIL 4
201
207
#define WORD_LOGICAL 8
202
 
#define WORD_ALLOW_LEADING_DOT 16
 
208
#define WORD_SEARCH_LAST_DOT 16
 
209
#define WORD_ALLOW_LEADING_DOT 32
203
210
 
204
211
static cl_object
205
 
make_one(const char *s, cl_index end)
 
212
make_one(cl_object s, cl_index start, cl_index end)
206
213
{
207
 
        cl_object x = cl_alloc_simple_base_string(end);
208
 
        memcpy(x->base_string.self, s, end);
209
 
        return(x);
 
214
        return cl_subseq(3, s, MAKE_FIXNUM(start), MAKE_FIXNUM(end));
210
215
}
211
216
 
212
217
static int is_colon(int c) { return c == ':'; }
224
229
translate_common_case(cl_object str)
225
230
{
226
231
        int string_case;
227
 
        if (type_of(str) != t_base_string) {
 
232
        if (!ecl_stringp(str)) {
228
233
                /* Pathnames may contain some other objects, such as symbols,
229
234
                 * numbers, etc, which need not be translated */
230
235
                return str;
272
277
        } else {
273
278
                cl_object l;
274
279
                list = cl_copy_list(list);
275
 
                for (l = cl_copy_list(list); !endp(l); l = CDR(l)) {
 
280
                for (l = list; !ecl_endp(l); l = CDR(l)) {
276
281
                        /* It is safe to pass anything to translate_pathname_case,
277
282
                         * because it will only transform strings, leaving other
278
283
                         * object (such as symbols) unchanged.*/
295
300
 *      5) A non empty string
296
301
 */
297
302
static cl_object
298
 
parse_word(const char *s, delim_fn delim, int flags, cl_index start,
 
303
parse_word(cl_object s, delim_fn delim, int flags, cl_index start,
299
304
           cl_index end, cl_index *end_of_word)
300
305
{
301
 
        cl_index i, j;
 
306
        cl_index i, j, last_delim = end;
302
307
        bool wild_inferiors = FALSE;
303
308
 
304
309
        i = j = start;
305
 
        if ((flags & WORD_ALLOW_LEADING_DOT) && (i < end) && delim(s[i]))
306
 
                i++;
307
 
        for (; i < end && !delim(s[i]); i++) {
308
 
                char c = s[i];
 
310
        for (; i < end; i++) {
309
311
                bool valid_char;
 
312
                cl_index c = ecl_char(s, i);
 
313
                if (delim(c)) {
 
314
                        if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) {
 
315
                                /* Leading dot is included */
 
316
                                continue;
 
317
                        }
 
318
                        last_delim = i;
 
319
                        if (!(flags & WORD_SEARCH_LAST_DOT)) {
 
320
                                break;
 
321
                        }
 
322
                }
310
323
                if (c == '*') {
311
324
                        if (!(flags & WORD_ALLOW_ASTERISK))
312
325
                                valid_char = FALSE; /* Asterisks not allowed in this word */
313
326
                        else {
314
 
                                wild_inferiors = (i > start && s[i-1] == '*');
 
327
                                wild_inferiors = (i > start && ecl_char(s, i-1) == '*');
315
328
                                valid_char = TRUE; /* single "*" */
316
329
                        }
317
330
                }
326
339
                        return @':error';
327
340
                }
328
341
        }
329
 
        if (i < end)
 
342
        if (i > last_delim) {
 
343
                /* Go back to the position of the last delimiter */
 
344
                i = last_delim;
 
345
        }
 
346
        if (i < end) {
330
347
                *end_of_word = i+1;
331
 
        else {
 
348
        } else {
332
349
                *end_of_word = end;
333
350
                /* We have reached the end of the string without finding
334
351
                   the proper delimiter */
337
354
                        return Cnil;
338
355
                }
339
356
        }
340
 
        s += j;
341
357
        switch(i-j) {
342
358
        case 0:
343
359
                if (flags & WORD_EMPTY_IS_NIL)
344
360
                        return Cnil;
345
361
                return cl_core.null_string;
346
362
        case 1:
347
 
                if (s[0] == '*')
 
363
                if (ecl_char(s,j) == '*')
348
364
                        return @':wild';
349
365
                break;
350
 
        case 2:
351
 
                if (s[0] == '*' && s[1] == '*')
 
366
        case 2: {
 
367
                cl_index c0 = ecl_char(s,j);
 
368
                cl_index c1 = ecl_char(s,j+1);
 
369
                if (c0 == '*' && c1 == '*')
352
370
                        return @':wild-inferiors';
353
 
                if (!(flags & WORD_LOGICAL) && s[0] == '.' && s[1] == '.')
 
371
                if (!(flags & WORD_LOGICAL) && c0 == '.' && c1 == '.')
354
372
                        return @':up';
355
373
                break;
 
374
        }
356
375
        default:
357
376
                if (wild_inferiors)     /* '**' surrounded by other characters */
358
377
                        return @':error';
359
378
        }
360
 
        return make_one(s, i-j);
 
379
        return make_one(s, j, i);
361
380
}
362
381
 
363
382
/*
370
389
 */
371
390
 
372
391
static cl_object
373
 
parse_directories(const char *s, int flags, cl_index start, cl_index end,
 
392
parse_directories(cl_object s, int flags, cl_index start, cl_index end,
374
393
                  cl_index *end_of_dir)
375
394
{
376
395
        cl_index i, j;
399
418
}
400
419
 
401
420
bool
402
 
logical_hostname_p(cl_object host)
 
421
ecl_logical_hostname_p(cl_object host)
403
422
{
404
 
        if (type_of(host) != t_base_string)
 
423
        if (!ecl_stringp(host))
405
424
                return FALSE;
406
425
        return !Null(@assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal'));
407
426
}
433
452
 *
434
453
 */
435
454
cl_object
436
 
parse_namestring(const char *s, cl_index start, cl_index end, cl_index *ep,
437
 
                 cl_object default_host)
 
455
ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep,
 
456
                     cl_object default_host)
438
457
{
439
458
        cl_object host, device, path, name, type, aux, version;
440
459
        bool logical;
455
474
                if (host == Cnil || host == @':error')
456
475
                        host = default_host;
457
476
        }
458
 
        if (!logical_hostname_p(host))
 
477
        if (!ecl_logical_hostname_p(host))
459
478
                goto physical;
460
479
        /*
461
480
         * Logical pathname format:
477
496
                return Cnil;
478
497
        type = Cnil;
479
498
        version = Cnil;
480
 
        if (*ep == start || s[*ep-1] != '.')
 
499
        if (*ep == start || ecl_char(s, *ep-1) != '.')
481
500
                goto make_it;
482
501
        type = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK |
483
502
                          WORD_EMPTY_IS_NIL, *ep, end, ep);
484
503
        if (type == @':error')
485
504
                return Cnil;
486
 
        if (*ep == start || s[*ep-1] != '.')
 
505
        if (*ep == start || ecl_char(s, *ep-1) != '.')
487
506
                goto make_it;
488
507
        aux = parse_word(s, is_null, WORD_LOGICAL | WORD_ALLOW_ASTERISK |
489
508
                         WORD_EMPTY_IS_NIL, *ep, end, ep);
493
512
                version = aux;
494
513
        } else {
495
514
                version = cl_parse_integer(3, aux, @':junk-allowed', Ct);
496
 
                if (cl_integerp(version) != Cnil && number_plusp(version) &&
497
 
                    fix(VALUES(1)) == aux->base_string.fillp)
 
515
                if (cl_integerp(version) != Cnil && ecl_plusp(version) &&
 
516
                    fix(VALUES(1)) == ecl_length(aux))
498
517
                        ;
499
518
                else if (cl_string_equal(2, aux, @':newest') != Cnil)
500
519
                        version = @':newest';
513
532
        if (device == @':error')
514
533
                device = Cnil;
515
534
        else if (device != Cnil) {
516
 
                if (type_of(device) != t_base_string)
 
535
                if (!ecl_stringp(device))
517
536
                        return Cnil;
518
 
                if (strcmp(device->base_string.self, "file") == 0)
 
537
                if (@string-equal(2, device, @':file') == Ct)
519
538
                        device = Cnil;
520
539
        }
521
540
        start = *ep;
522
 
        if (start <= end - 2 && is_slash(s[start]) && is_slash(s[start+1])) {
 
541
        if ((start+2) <= end && is_slash(ecl_char(s, start)) &&
 
542
            is_slash(ecl_char(s, start+1)))
 
543
        {
523
544
                host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL,
524
545
                                  start+2, end, ep);
525
546
                if (host != Cnil) {
526
547
                        start = *ep;
527
 
                        if (is_slash(s[--start])) *ep = start;
 
548
                        if (is_slash(ecl_char(s,--start))) *ep = start;
528
549
                }
529
 
        } else
530
 
                host = Cnil;
531
 
        if (host == @':error')
532
 
                host = Cnil;
533
 
        else if (host != Cnil) {
534
 
                if (type_of(host) != t_base_string)
 
550
        } else {
 
551
                host = Cnil;
 
552
        }
 
553
        if (host == @':error') {
 
554
                host = Cnil;
 
555
        } else if (host != Cnil) {
 
556
                if (!ecl_stringp(host))
535
557
                        return Cnil;
536
558
        }
537
559
        path = parse_directories(s, 0, *ep, end, ep);
543
565
        }
544
566
        if (path == @':error')
545
567
                return Cnil;
546
 
        name = parse_word(s, is_dot, WORD_ALLOW_LEADING_DOT |
 
568
        start = *ep;
 
569
        name = parse_word(s, is_dot,
 
570
                          WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT |
547
571
                          WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL,
548
 
                          *ep, end, ep);
 
572
                          start, end, ep);
549
573
        if (name == @':error')
550
574
                return Cnil;
551
 
        if (*ep == start || s[*ep-1] != '.') {
 
575
        if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') {
552
576
                type = Cnil;
553
577
        } else {
554
578
                type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep);
555
579
                if (type == @':error')
556
580
                        return Cnil;
557
581
        }
558
 
        if (name != Cnil || type != Cnil)
559
 
                version = @':newest';
560
 
        else
561
 
                version = Cnil;
 
582
        version = (name != Cnil || type != Cnil) ? @':newest' : Cnil;
562
583
 make_it:
563
584
        if (*ep >= end) *ep = end;
564
 
        path = make_pathname(host, device, path, name, type, version);
 
585
        path = ecl_make_pathname(host, device, path, name, type, version);
565
586
        path->pathname.logical = logical;
566
587
        return path;
567
588
}
573
594
         * coerced to type PATHNAME. Special care is taken so that we do
574
595
         * not enter an infinite loop when using PARSE-NAMESTRING, because
575
596
         * this routine might itself try to use the value of this variable. */
576
 
        cl_object path = symbol_value(@'*default-pathname-defaults*');
577
 
        if (type_of(path) == t_base_string) {
 
597
        cl_object path = ecl_symbol_value(@'*default-pathname-defaults*');
 
598
        if (ecl_stringp(path)) {
578
599
                /* Avoids infinite loop by giving a third argument to
579
600
                 * parse-namestring */
580
601
                path = cl_parse_namestring(3, path, Cnil, Cnil);
589
610
{
590
611
L:
591
612
        switch (type_of(x)) {
 
613
#ifdef ECL_UNICODE
 
614
        case t_string:
 
615
#endif
592
616
        case t_base_string:
593
617
                x = cl_parse_namestring(1, x);
594
618
 
609
633
                        goto L;
610
634
 
611
635
                case smm_synonym:
612
 
                        x = symbol_value(x->stream.object0);
 
636
                        x = ecl_symbol_value(x->stream.object0);
613
637
                        goto L;
614
638
                default:
615
639
                        ;/* Fall through to error message */
659
683
        if (component == Cnil || component == @':name') {
660
684
                cl_object name = pathname->pathname.name;
661
685
                if (name != Cnil &&
662
 
                    (name == @':wild' || (!SYMBOLP(name) && member_char('*', name))))
 
686
                    (name == @':wild' || (!SYMBOLP(name) && ecl_member_char('*', name))))
663
687
                        @(return Ct);
664
688
                checked = 1;
665
689
        }
666
690
        if (component == Cnil || component == @':type') {
667
691
                cl_object name = pathname->pathname.type;
668
692
                if (name != Cnil &&
669
 
                    (name == @':wild' || (!SYMBOLP(name) && member_char('*', name))))
 
693
                    (name == @':wild' || (!SYMBOLP(name) && ecl_member_char('*', name))))
670
694
                        @(return Ct);
671
695
                checked = 1;
672
696
        }
677
701
                        cl_object name = CAR(list);
678
702
                        if (name != Cnil &&
679
703
                            (name == @':wild' || name == @':wild-inferiors' ||
680
 
                             (!SYMBOLP(name) && member_char('*', name))))
 
704
                             (!SYMBOLP(name) && ecl_member_char('*', name))))
681
705
                        {
682
706
                                @(return Ct)
683
707
                        }
754
778
                FEerror("Pathname ~A does not have a physical namestring",
755
779
                        1, pathname_orig);
756
780
        }
757
 
        if (namestring->base_string.fillp >= MAXPATHLEN - 16)
 
781
        if (cl_core.path_max != -1 &&
 
782
            ecl_length(namestring) >= cl_core.path_max - 16)
758
783
                FEerror("Too long filename: ~S.", 1, namestring);
 
784
#ifdef ECL_UNICODE
 
785
        if (type_of(namestring) == t_string) {
 
786
                FEerror("The filesystem does not accept filenames with extended characters: ~S",
 
787
                        1, namestring);
 
788
        }
 
789
#endif
759
790
        return namestring;
760
791
}
761
792
 
762
793
#define default_device(host) Cnil
763
794
 
764
795
cl_object
765
 
merge_pathnames(cl_object path, cl_object defaults, cl_object default_version)
 
796
ecl_merge_pathnames(cl_object path, cl_object defaults, cl_object default_version)
766
797
{
767
798
        cl_object host, device, directory, name, type, version;
768
799
 
784
815
        else if (CAR(path->pathname.directory) == @':absolute')
785
816
                directory = path->pathname.directory;
786
817
        else if (!Null(defaults->pathname.directory))
787
 
                directory = append(defaults->pathname.directory,
 
818
                directory = ecl_append(defaults->pathname.directory,
788
819
                                   CDR(path->pathname.directory));
789
820
        else
790
821
                directory = path->pathname.directory;
802
833
        /*
803
834
                In this implementation, version is not considered
804
835
        */
805
 
        defaults = make_pathname(host, device, directory, name, type, version);
 
836
        defaults = ecl_make_pathname(host, device, directory, name, type, version);
806
837
        return defaults;
807
838
}
808
839
 
809
 
static void
810
 
push_c_string(cl_object buffer, const char *s, cl_index length)
811
 
{
812
 
        for (; length; length--, s++) {
813
 
                ecl_string_push_extend(buffer, *s);
814
 
        }
815
 
}
816
 
 
817
 
static void
818
 
push_string(cl_object buffer, cl_object string)
819
 
{
820
 
        string = cl_string(string);
821
 
        push_c_string(buffer, string->base_string.self, string->base_string.fillp);
822
 
}
823
 
 
824
840
/*
825
841
        ecl_namestring(x, flag) converts a pathname to a namestring.
826
842
        if flag is true, then the pathname may be coerced to the requirements
838
854
        x = cl_pathname(x);
839
855
 
840
856
        /* INV: Pathnames can only be created by mergin, parsing namestrings
841
 
         * or using make_pathname(). In all of these cases ECL will complain
 
857
         * or using ecl_make_pathname(). In all of these cases ECL will complain
842
858
         * at creation time if the pathname has wrong components.
843
859
         */
844
860
        buffer = ecl_make_string_output_stream(128);
866
882
                }
867
883
        }
868
884
        l = x->pathname.directory;
869
 
        if (endp(l))
 
885
        if (ecl_endp(l))
870
886
                goto NO_DIRECTORY;
871
887
        y = CAR(l);
872
888
        if (y == @':relative') {
876
892
                if (!logical)
877
893
                        ecl_write_char(DIR_SEPARATOR, buffer);
878
894
        }
879
 
        for (l = CDR(l); !endp(l); l = CDR(l)) {
 
895
        for (l = CDR(l); !ecl_endp(l); l = CDR(l)) {
880
896
                y = CAR(l);
881
897
                if (y == @':up') {
882
898
                        writestr_stream("..", buffer);
965
981
        if (host != Cnil) {
966
982
                host = cl_string(host);
967
983
        }
968
 
        if (type_of(thing) != t_base_string) {
 
984
        if (!ecl_stringp(thing)) {
969
985
                output = cl_pathname(thing);
970
986
        } else {
971
987
                cl_object default_host = host;
974
990
                        default_host = defaults->pathname.host;
975
991
                }
976
992
                get_string_start_end(thing, start, end, &s, &e);
977
 
                output = parse_namestring(thing->base_string.self, s, e - s, &ee,
978
 
                                          default_host);
979
 
                start = MAKE_FIXNUM(s + ee);
980
 
                if (output == Cnil || ee != e - s) {
 
993
                output = ecl_parse_namestring(thing, s, e, &ee, default_host);
 
994
                start = MAKE_FIXNUM(ee);
 
995
                if (output == Cnil || ee != e) {
981
996
                        if (Null(junk_allowed)) {
982
997
                                FEparse_error("Cannot parse the namestring ~S~%"
983
998
                                              "from ~S to ~S.", Cnil,
986
1001
                        goto OUTPUT;
987
1002
                }
988
1003
        }
989
 
        if (host != Cnil && !equal(output->pathname.host, host)) {
 
1004
        if (host != Cnil && !ecl_equal(output->pathname.host, host)) {
990
1005
                FEerror("The pathname ~S does not contain the required host ~S.",
991
1006
                        2, thing, host);
992
1007
        }
1000
1015
@
1001
1016
        path = cl_pathname(path);
1002
1017
        defaults = cl_pathname(defaults);
1003
 
        @(return merge_pathnames(path, defaults, default_version))
 
1018
        @(return ecl_merge_pathnames(path, defaults, default_version))
1004
1019
@)
1005
1020
 
1006
1021
@(defun make_pathname (&key (host OBJNULL) (device OBJNULL) (directory OBJNULL)
1011
1026
@
1012
1027
        if (Null(defaults)) {
1013
1028
                defaults = si_default_pathname_defaults();
1014
 
                defaults = make_pathname(defaults->pathname.host,
1015
 
                                         Cnil, Cnil, Cnil, Cnil, Cnil);
 
1029
                defaults = ecl_make_pathname(defaults->pathname.host,
 
1030
                                             Cnil, Cnil, Cnil, Cnil, Cnil);
1016
1031
        } else {
1017
1032
                defaults = cl_pathname(defaults);
1018
1033
        }
1019
 
        x = make_pathname(host != OBJNULL? translate_pathname_case(host,scase)
1020
 
                                         : defaults->pathname.host,
1021
 
                          device != OBJNULL? translate_pathname_case(device,scase)
1022
 
                                           : defaults->pathname.device,
1023
 
                          directory != OBJNULL? translate_directory_case(directory,scase)
1024
 
                                              : defaults->pathname.directory,
1025
 
                          name != OBJNULL? translate_pathname_case(name,scase)
1026
 
                                              : defaults->pathname.name,
1027
 
                          type != OBJNULL? translate_pathname_case(type,scase)
1028
 
                                              : defaults->pathname.type,
1029
 
                          version != OBJNULL? version : defaults->pathname.version);
 
1034
        x = ecl_make_pathname(host != OBJNULL? translate_pathname_case(host,scase)
 
1035
                              : defaults->pathname.host,
 
1036
                              device != OBJNULL? translate_pathname_case(device,scase)
 
1037
                              : defaults->pathname.device,
 
1038
                              directory != OBJNULL? translate_directory_case(directory,scase)
 
1039
                              : defaults->pathname.directory,
 
1040
                              name != OBJNULL? translate_pathname_case(name,scase)
 
1041
                              : defaults->pathname.name,
 
1042
                              type != OBJNULL? translate_pathname_case(type,scase)
 
1043
                              : defaults->pathname.type,
 
1044
                              version != OBJNULL? version : defaults->pathname.version);
1030
1045
        @(return x)
1031
1046
@)
1032
1047
 
1084
1099
cl_file_namestring(cl_object pname)
1085
1100
{
1086
1101
        pname = cl_pathname(pname);
1087
 
        @(return ecl_namestring(make_pathname(Cnil, Cnil, Cnil,
1088
 
                                              pname->pathname.name,
1089
 
                                              pname->pathname.type,
1090
 
                                              pname->pathname.version),
 
1102
        @(return ecl_namestring(ecl_make_pathname(Cnil, Cnil, Cnil,
 
1103
                                                  pname->pathname.name,
 
1104
                                                  pname->pathname.type,
 
1105
                                                  pname->pathname.version),
1091
1106
                                1))
1092
1107
}
1093
1108
 
1095
1110
cl_directory_namestring(cl_object pname)
1096
1111
{
1097
1112
        pname = cl_pathname(pname);
1098
 
        @(return ecl_namestring(make_pathname(Cnil, Cnil,
1099
 
                                              pname->pathname.directory,
1100
 
                                              Cnil, Cnil, Cnil),
 
1113
        @(return ecl_namestring(ecl_make_pathname(Cnil, Cnil,
 
1114
                                                  pname->pathname.directory,
 
1115
                                                  Cnil, Cnil, Cnil),
1101
1116
                                1))
1102
1117
}
1103
1118
 
1111
1126
        @(return pname)
1112
1127
}
1113
1128
 
 
1129
#define EN_MATCH(p1,p2,el) (ecl_equalp(p1->pathname.el, p2->pathname.el)? Cnil : p1->pathname.el)
 
1130
 
1114
1131
@(defun enough_namestring (path
1115
1132
        &o (defaults si_default_pathname_defaults()))
1116
 
        cl_object newpath;
 
1133
        cl_object newpath, pathdir, defaultdir, fname;
1117
1134
@
1118
1135
        defaults = cl_pathname(defaults);
1119
1136
        path = cl_pathname(path);
 
1137
        pathdir = path->pathname.directory;
 
1138
        defaultdir = defaults->pathname.directory;
 
1139
        if (Null(pathdir)) {
 
1140
                pathdir = CONS(@':relative', Cnil);
 
1141
        } else if (Null(defaultdir)) {
 
1142
                /* The defaults pathname does not have a directory. */
 
1143
        } else if (CAR(pathdir) == @':relative') {
 
1144
                /* The pathname is relative to the default one one, so we just output the
 
1145
                   original one */
 
1146
        } else {
 
1147
                /* The new pathname is an absolute one. We compare it with the defaults
 
1148
                   and if they have some common elements, we just output the remaining ones. */
 
1149
                cl_index begin;
 
1150
                cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir,
 
1151
                                              @':test', @'equal');
 
1152
                if (dir_begin == Cnil) {
 
1153
                        pathdir = Cnil;
 
1154
                } else if (dir_begin == cl_length(defaultdir)) {
 
1155
                        pathdir = funcall(3, @'subseq', pathdir, dir_begin);
 
1156
                        pathdir = CONS(@':relative', pathdir);
 
1157
                }
 
1158
        }
 
1159
        fname = EN_MATCH(path, defaults, name);
 
1160
        if (fname == Cnil) fname = path->pathname.name;
 
1161
        /* Create a path with all elements that do not match the default */
1120
1162
        newpath
1121
 
        = make_pathname(equalp(path->pathname.host, defaults->pathname.host) ?
1122
 
                        Cnil : path->pathname.host,
1123
 
                        equalp(path->pathname.device,
1124
 
                               defaults->pathname.device) ?
1125
 
                        Cnil : path->pathname.device,
1126
 
                        equalp(path->pathname.directory,
1127
 
                               defaults->pathname.directory) ?
1128
 
                        Cnil : path->pathname.directory,
1129
 
                        equalp(path->pathname.name, defaults->pathname.name) ?
1130
 
                        Cnil : path->pathname.name,
1131
 
                        equalp(path->pathname.type, defaults->pathname.type) ?
1132
 
                        Cnil : path->pathname.type,
1133
 
                        equalp(path->pathname.version,
1134
 
                               defaults->pathname.version) ?
1135
 
                        Cnil : path->pathname.version);
 
1163
        = ecl_make_pathname(EN_MATCH(path, defaults, host),
 
1164
                            EN_MATCH(path, defaults, device),
 
1165
                            pathdir, fname,
 
1166
                            EN_MATCH(path, defaults, type),
 
1167
                            EN_MATCH(path, defaults, version));
1136
1168
        newpath->pathname.logical = path->pathname.logical;
1137
1169
        @(return ecl_namestring(newpath, 1))
1138
1170
@)
 
1171
#undef EN_MATCH
1139
1172
 
1140
1173
/* --------------- PATHNAME MATCHING ------------------ */
1141
1174
 
1142
1175
static bool path_item_match(cl_object a, cl_object mask);
1143
1176
 
1144
1177
static bool
1145
 
do_path_item_match(const char *s, const char *p) {
1146
 
        const char *next;
1147
 
        while (*s) {
1148
 
          if (*p == '*') {
1149
 
            /* Match any group of characters */
1150
 
            next = p+1;
1151
 
            while (*s && *s != *next) s++;
1152
 
            if (do_path_item_match(s,next))
1153
 
              return TRUE;
1154
 
            /* starts back from the '*' */
1155
 
            if (!*s)
1156
 
              return FALSE;
1157
 
            s++;
1158
 
          } else if (*s != *p)
1159
 
            return FALSE;
1160
 
          else
1161
 
            s++, p++;
 
1178
do_path_item_match(cl_object s, cl_index j, cl_object p, cl_index i)
 
1179
{
 
1180
        cl_index ls = ecl_length(s), lp = ecl_length(p);
 
1181
        cl_index cp;
 
1182
        while (i < lp) {
 
1183
                cl_index cp = ecl_char(p, i);
 
1184
                if (cp == '*') {
 
1185
                        /* An asterisk in the patter matches any number
 
1186
                         * of characters. We try the shortest sequence
 
1187
                         * that matches. */
 
1188
                        cl_index cn = 0, next;
 
1189
                        for (next = i+1;
 
1190
                             next < lp && ((cn = ecl_char(p, next)) == '*');
 
1191
                             next++)
 
1192
                                ;
 
1193
                        if (next == lp) {
 
1194
                                return TRUE;
 
1195
                        }
 
1196
                        while (j < ls) {
 
1197
                                if (do_path_item_match(s, j, p, next)) {
 
1198
                                        return TRUE;
 
1199
                                }
 
1200
                                j++;
 
1201
                        }
 
1202
                        return FALSE;
 
1203
                }
 
1204
                if ((j >= ls) || (cp != ecl_char(s, j))) {
 
1205
                        /* Either there are no characters left in "s"
 
1206
                         * or the next character does not match. */
 
1207
                        return FALSE;
 
1208
                }
 
1209
                i++; j++;
1162
1210
        }
1163
 
        return (*p == 0);
 
1211
        return (j >= ls);
1164
1212
}
1165
1213
 
1166
1214
static bool
1169
1217
                return TRUE;
1170
1218
        /* If a component in the tested path is a wildcard field, this
1171
1219
           can only be matched by the same wildcard field in the mask */
1172
 
        if (type_of(a) != t_base_string || mask == Cnil)
 
1220
        if (!ecl_stringp(a) || mask == Cnil)
1173
1221
                return (a == mask);
1174
 
        if (type_of(mask) != t_base_string)
 
1222
        if (!ecl_stringp(mask))
1175
1223
                FEerror("~S is not supported as mask for pathname-match-p", 1, mask);
1176
 
        return do_path_item_match(a->base_string.self, mask->base_string.self);
 
1224
        return do_path_item_match(a, 0, mask, 0);
1177
1225
}
1178
1226
 
1179
1227
static bool
1180
1228
path_list_match(cl_object a, cl_object mask) {
1181
1229
        cl_object item_mask;
1182
 
        while (!endp(mask)) {
 
1230
        while (!ecl_endp(mask)) {
1183
1231
                item_mask = CAR(mask);
1184
1232
                mask = CDR(mask);
1185
1233
                if (item_mask == @':wild-inferiors') {
1186
 
                        if (endp(mask))
 
1234
                        if (ecl_endp(mask))
1187
1235
                                return TRUE;
1188
 
                        while (!endp(a)) {
 
1236
                        while (!ecl_endp(a)) {
1189
1237
                                if (path_list_match(a, mask))
1190
1238
                                        return TRUE;
1191
1239
                                a = CDR(a);
1192
1240
                        }
1193
1241
                        return FALSE;
1194
 
                } else if (endp(a)) {
 
1242
                } else if (ecl_endp(a)) {
1195
1243
                        /* A NIL directory should match against :absolute
1196
1244
                           or :relative, in order to perform suitable translations. */
1197
1245
                        if (item_mask != @':absolute' && item_mask != @':relative')
1202
1250
                        a = CDR(a);
1203
1251
                }
1204
1252
        }
1205
 
        if (!endp(a))
 
1253
        if (!ecl_endp(a))
1206
1254
                return FALSE;
1207
1255
        return TRUE;
1208
1256
}
1224
1272
        if (!Null(mask->pathname.directory) &&
1225
1273
            !path_list_match(path->pathname.directory, mask->pathname.directory))
1226
1274
                goto OUTPUT;
1227
 
        if (!Null(mask->pathname.name) &&
1228
 
            !path_item_match(path->pathname.name, mask->pathname.name))
 
1275
        if (!path_item_match(path->pathname.name, mask->pathname.name))
1229
1276
                goto OUTPUT;
1230
 
        if (!Null(mask->pathname.type) &&
1231
 
            !path_item_match(path->pathname.type, mask->pathname.type))
 
1277
        if (!path_item_match(path->pathname.type, mask->pathname.type))
1232
1278
                goto OUTPUT;
1233
1279
        if (Null(mask->pathname.version) ||
1234
1280
            path_item_match(path->pathname.version, mask->pathname.version))
1243
1289
coerce_to_from_pathname(cl_object x, cl_object host)
1244
1290
{
1245
1291
        switch (type_of(x)) {
 
1292
#ifdef ECL_UNICODE
 
1293
        case t_string:
 
1294
#endif
1246
1295
        case t_base_string:
1247
1296
                x = cl_parse_namestring(2, x, host);
1248
1297
        case t_pathname:
1254
1303
}
1255
1304
 
1256
1305
@(defun si::pathname_translations (host &optional (set OBJNULL))
1257
 
        cl_index parsed_length, length;
 
1306
        cl_index parsed_len, len;
1258
1307
        cl_object pair, l;
1259
1308
@
1260
1309
        /* Check that host is a valid host name */
1261
 
        assert_type_base_string(host);
1262
 
        length = host->base_string.fillp;
1263
 
        parse_word(host->base_string.self, is_null, WORD_LOGICAL, 0, length,
1264
 
                   &parsed_length);
1265
 
        if (parsed_length < host->base_string.fillp)
 
1310
        host = ecl_check_type_string(@'si::pathname-translations',host);
 
1311
        len = ecl_length(host);
 
1312
        parse_word(host, is_null, WORD_LOGICAL, 0, len, &parsed_len);
 
1313
        if (parsed_len < len) {
1266
1314
                FEerror("Wrong host syntax ~S", 1, host);
1267
 
 
 
1315
        }
1268
1316
        /* Find its translation list */
1269
1317
        pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal');
1270
 
        if (set == OBJNULL)
1271
 
                @(return ((pair == Cnil)? Cnil : CADR(pair)))
1272
 
 
 
1318
        if (set == OBJNULL) {
 
1319
                @(return ((pair == Cnil)? Cnil : CADR(pair)));
 
1320
        }
1273
1321
        /* Set the new translation list */
1274
1322
        assert_type_list(set);
1275
1323
        if (pair == Cnil) {
1276
1324
                pair = CONS(host, CONS(Cnil, Cnil));
1277
1325
                cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations);
1278
1326
        }
1279
 
        for (l = set, set = Cnil; !endp(l); l = CDR(l)) {
 
1327
        for (l = set, set = Cnil; !ecl_endp(l); l = CDR(l)) {
1280
1328
                cl_object item = CAR(l);
1281
1329
                cl_object from = coerce_to_from_pathname(cl_car(item), host);
1282
1330
                cl_object to = cl_pathname(cl_cadr(item));
1287
1335
@)
1288
1336
 
1289
1337
static cl_object
1290
 
find_wilds(cl_object l, cl_object source_item, cl_object match)
 
1338
find_wilds(cl_object l, cl_object source, cl_object match)
1291
1339
{
1292
 
        const char *a, *b;
1293
 
        cl_index i, j, k, ia, ib;
 
1340
        cl_index i, j, k, ls, lm;
1294
1341
 
1295
1342
        if (match == @':wild')
1296
 
                return CONS(source_item, Cnil);
1297
 
        if (type_of(match) != t_base_string || type_of(source_item) != t_base_string) {
1298
 
                if (match != source_item)
 
1343
                return CONS(source, Cnil);
 
1344
        if (!ecl_stringp(match) || !ecl_stringp(source)) {
 
1345
                if (match != source)
1299
1346
                        return @':error';
1300
1347
                return l;
1301
1348
        }
1302
 
        a  = source_item->base_string.self;
1303
 
        ia = source_item->base_string.fillp;
1304
 
        b  = match->base_string.self;
1305
 
        ib = match->base_string.fillp;
1306
 
        for(i = j = 0; i < ia && j < ib; ) {
1307
 
                if (b[j] == '*') {
1308
 
                        for (j++, k = i; k < ia && a[k] != b[j]; k++)
 
1349
        ls = ecl_length(source);
 
1350
        lm = ecl_length(match);
 
1351
        for(i = j = 0; i < ls && j < lm; ) {
 
1352
                cl_index pattern_char = ecl_char(match,j);
 
1353
                if (pattern_char == '*') {
 
1354
                        for (j++, k = i;
 
1355
                             k < ls && ecl_char(source,k) != pattern_char;
 
1356
                             k++)
1309
1357
                                ;
1310
 
                        l = CONS(make_one(&a[i], k-i), l);
 
1358
                        l = CONS(make_one(source, i, k), l);
1311
1359
                        i = k;
1312
1360
                        continue;
1313
1361
                }
1314
 
                if (a[i] != b[j])
 
1362
                if (ecl_char(source,i) != pattern_char)
1315
1363
                        return @':error';
1316
1364
                i++, j++;
1317
1365
        }
1318
 
        if (i < ia || j < ib)
 
1366
        if (i < ls || j < lm)
1319
1367
                return @':error';
1320
1368
        return l;
1321
1369
}
1325
1373
{
1326
1374
        cl_object l = Cnil, l2;
1327
1375
 
1328
 
        while (!endp(mask)) {
 
1376
        while (!ecl_endp(mask)) {
1329
1377
                cl_object item_mask = CAR(mask);
1330
1378
                mask = CDR(mask);
1331
1379
                if (item_mask == @':wild-inferiors') {
1332
1380
                        l2 = Cnil;
1333
1381
                        while (!path_list_match(a, mask)) {
1334
 
                                if (endp(a))
 
1382
                                if (ecl_endp(a))
1335
1383
                                        return @':error';
1336
1384
                                l2 = CONS(CAR(a),l2);
1337
1385
                                a = CDR(a);
1338
1386
                        }
1339
1387
                        l = CONS(l2, l);
1340
 
                } else if (endp(a)) {
 
1388
                } else if (ecl_endp(a)) {
1341
1389
                        /* A NIL directory should match against :absolute
1342
1390
                           or :relative, in order to perform suitable translations. */
1343
1391
                        if (item_mask != @':absolute' && item_mask != @':relative')
1357
1405
static cl_object
1358
1406
copy_wildcards(cl_object *wilds_list, cl_object pattern)
1359
1407
{
1360
 
        char *s;
1361
1408
        cl_index i, l, j;
1362
1409
        bool new_string;
1363
 
        cl_object wilds = *wilds_list;
 
1410
        cl_object wilds = *wilds_list, token;
1364
1411
 
1365
1412
        if (pattern == @':wild') {
1366
 
                if (endp(wilds))
 
1413
                if (ecl_endp(wilds))
1367
1414
                        return @':error';
1368
1415
                pattern = CAR(wilds);
1369
1416
                *wilds_list = CDR(wilds);
1371
1418
        }
1372
1419
        if (pattern == @':wild-inferiors')
1373
1420
                return @':error';
1374
 
        if (type_of(pattern) != t_base_string)
 
1421
        if (!ecl_stringp(pattern))
1375
1422
                return pattern;
1376
1423
 
1377
1424
        new_string = FALSE;
1378
 
        s = pattern->base_string.self;
1379
 
        l = pattern->base_string.fillp;
1380
 
        cl_env.token->base_string.fillp = 0;
1381
 
 
 
1425
        l = ecl_length(pattern);
 
1426
        token = si_get_buffer_string();
1382
1427
        for (j = i = 0; i < l; ) {
1383
 
                if (s[i] != '*') {
 
1428
                cl_index c = ecl_char(pattern, i);
 
1429
                if (c != '*') {
1384
1430
                        i++;
1385
1431
                        continue;
1386
1432
                }
1387
 
                if (i != j)
1388
 
                        push_c_string(cl_env.token, &s[j], i-j);
 
1433
                if (i != j) {
 
1434
                        push_substring(token, pattern, j, i);
 
1435
                }
1389
1436
                new_string = TRUE;
1390
 
                if (endp(wilds))
 
1437
                if (ecl_endp(wilds)) {
1391
1438
                        return @':error';
1392
 
                push_string(cl_env.token, CAR(wilds));
 
1439
                }
 
1440
                push_string(token, CAR(wilds));
1393
1441
                wilds = CDR(wilds);
1394
1442
                j = i++;
1395
1443
        }
1396
1444
        /* Only create a new string when needed */
1397
 
        if (new_string)
1398
 
                pattern = si_copy_to_simple_base_string(cl_env.token);
 
1445
        if (new_string) {
 
1446
                if (ecl_fits_in_base_string(token)) {
 
1447
                        pattern = si_copy_to_simple_base_string(token);
 
1448
                } else {
 
1449
                        pattern = cl_copy_seq(token);
 
1450
                }
 
1451
        }
 
1452
        si_put_buffer_string(token);
1399
1453
        *wilds_list = wilds;
1400
1454
        return pattern;
1401
1455
}
1405
1459
{
1406
1460
        cl_object l = Cnil;
1407
1461
 
1408
 
        while (!endp(to)) {
 
1462
        while (!ecl_endp(to)) {
1409
1463
                cl_object d, mask = CAR(to);
1410
1464
                if (mask == @':wild-inferiors') {
1411
1465
                        cl_object list = *wilds;
1412
 
                        if (endp(list))
 
1466
                        if (ecl_endp(list))
1413
1467
                                return @':error';
1414
1468
                        else {
1415
1469
                                cl_object dirlist = CAR(list);
1416
1470
                                if (CONSP(dirlist))
1417
 
                                        l = append(CAR(list), l);
 
1471
                                        l = ecl_append(CAR(list), l);
1418
1472
                                else if (!Null(CAR(list)))
1419
1473
                                        return @':error';
1420
1474
                        }
1505
1559
                @(return pathname)
1506
1560
        }
1507
1561
        l = @si::pathname-translations(1, pathname->pathname.host);
1508
 
        for(; !endp(l); l = CDR(l)) {
 
1562
        for(; !ecl_endp(l); l = CDR(l)) {
1509
1563
                pair = CAR(l);
1510
1564
                if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) {
1511
1565
                        pathname = cl_translate_pathname(3, pathname, CAR(pair),