23
23
#include <ecl/ecl.h>
24
25
#include <string.h>
27
#define MAXPATHLEN 512
31
# define MAXPATHLEN PATH_MAX
33
# error "Either MAXPATHLEN or PATH_MAX should be defined"
37
28
typedef int (*delim_fn)(int);
40
ensure_simple_base_string(cl_object s)
31
push_substring(cl_object buffer, cl_object string, cl_index start, cl_index end)
47
return si_copy_to_simple_base_string(s);
33
string = cl_string(string);
35
ecl_string_push_extend(buffer, ecl_char(string, start));
41
push_string(cl_object buffer, cl_object string)
43
push_substring(buffer, string, 0, ecl_length(string));
54
47
destructively_check_directory(cl_object directory, bool logical)
66
59
if (CAR(directory) != @':absolute' && CAR(directory) != @':relative')
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') {
74
item = nth(i-1, directory);
67
item = ecl_nth(i-1, directory);
75
68
if (item == @':absolute' || item == @':wild-inferiors')
78
CDR(nthcdr(i-2, directory)) = CDR(ptr);
79
} if (item == @':up') {
71
CDR(ecl_nthcdr(i-2, directory)) = CDR(ptr);
72
} else if (item == @':up') {
82
item = nth(i-1, directory);
75
item = ecl_nth(i-1, directory);
83
76
if (item == @':absolute' || item == @':wild-inferiors')
85
78
} else if (item == @':relative' || item == @':absolute') {
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);
84
if (ecl_fits_in_base_string(item)) {
85
item = si_copy_to_simple_base_string(item);
88
item = cl_copy_seq(item);
92
if (strcmp(item->base_string.self,".")==0) {
95
CDR(nthcdr(i-1, directory)) = CDR(ptr);
96
} else if (strcmp(item->base_string.self,"..") == 0) {
97
CAR(directory) = @':back';
92
if (l && ecl_char(item,0) == '.') {
97
CDR(ecl_nthcdr(i-1, directory)) = CDR(ptr);
98
} else if (l == 2 && ecl_char(item,1) == '.') {
99
CAR(directory) = @':back';
100
103
} else if (item != @':wild' && item != @':wild-inferiors') {
101
104
return @':error';
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)
111
114
cl_object x, p, component;
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;
164
170
component = @':directory';
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);
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
205
make_one(const char *s, cl_index end)
212
make_one(cl_object s, cl_index start, cl_index end)
207
cl_object x = cl_alloc_simple_base_string(end);
208
memcpy(x->base_string.self, s, end);
214
return cl_subseq(3, s, MAKE_FIXNUM(start), MAKE_FIXNUM(end));
212
217
static int is_colon(int c) { return c == ':'; }
295
300
* 5) A non empty string
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)
306
cl_index i, j, last_delim = end;
302
307
bool wild_inferiors = FALSE;
305
if ((flags & WORD_ALLOW_LEADING_DOT) && (i < end) && delim(s[i]))
307
for (; i < end && !delim(s[i]); i++) {
310
for (; i < end; i++) {
312
cl_index c = ecl_char(s, i);
314
if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) {
315
/* Leading dot is included */
319
if (!(flags & WORD_SEARCH_LAST_DOT)) {
311
324
if (!(flags & WORD_ALLOW_ASTERISK))
312
325
valid_char = FALSE; /* Asterisks not allowed in this word */
314
wild_inferiors = (i > start && s[i-1] == '*');
327
wild_inferiors = (i > start && ecl_char(s, i-1) == '*');
315
328
valid_char = TRUE; /* single "*" */
343
359
if (flags & WORD_EMPTY_IS_NIL)
345
361
return cl_core.null_string;
363
if (ecl_char(s,j) == '*')
351
if (s[0] == '*' && s[1] == '*')
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 == '.')
357
376
if (wild_inferiors) /* '**' surrounded by other characters */
358
377
return @':error';
360
return make_one(s, i-j);
379
return make_one(s, j, i);
513
532
if (device == @':error')
515
534
else if (device != Cnil) {
516
if (type_of(device) != t_base_string)
535
if (!ecl_stringp(device))
518
if (strcmp(device->base_string.self, "file") == 0)
537
if (@string-equal(2, device, @':file') == Ct)
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)))
523
544
host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL,
524
545
start+2, end, ep);
525
546
if (host != Cnil) {
527
if (is_slash(s[--start])) *ep = start;
548
if (is_slash(ecl_char(s,--start))) *ep = start;
531
if (host == @':error')
533
else if (host != Cnil) {
534
if (type_of(host) != t_base_string)
553
if (host == @':error') {
555
} else if (host != Cnil) {
556
if (!ecl_stringp(host))
537
559
path = parse_directories(s, 0, *ep, end, ep);
544
566
if (path == @':error')
546
name = parse_word(s, is_dot, WORD_ALLOW_LEADING_DOT |
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,
549
573
if (name == @':error')
551
if (*ep == start || s[*ep-1] != '.') {
575
if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') {
554
578
type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep);
555
579
if (type == @':error')
558
if (name != Cnil || type != Cnil)
559
version = @':newest';
582
version = (name != Cnil || type != Cnil) ? @':newest' : Cnil;
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;
754
778
FEerror("Pathname ~A does not have a physical namestring",
755
779
1, pathname_orig);
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);
785
if (type_of(namestring) == t_string) {
786
FEerror("The filesystem does not accept filenames with extended characters: ~S",
759
790
return namestring;
762
793
#define default_device(host) Cnil
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)
767
798
cl_object host, device, directory, name, type, version;
803
834
In this implementation, version is not considered
805
defaults = make_pathname(host, device, directory, name, type, version);
836
defaults = ecl_make_pathname(host, device, directory, name, type, version);
810
push_c_string(cl_object buffer, const char *s, cl_index length)
812
for (; length; length--, s++) {
813
ecl_string_push_extend(buffer, *s);
818
push_string(cl_object buffer, cl_object string)
820
string = cl_string(string);
821
push_c_string(buffer, string->base_string.self, string->base_string.fillp);
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
974
990
default_host = defaults->pathname.host;
976
992
get_string_start_end(thing, start, end, &s, &e);
977
output = parse_namestring(thing->base_string.self, s, e - s, &ee,
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,
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);
1017
1032
defaults = cl_pathname(defaults);
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);
1111
1126
@(return pname)
1129
#define EN_MATCH(p1,p2,el) (ecl_equalp(p1->pathname.el, p2->pathname.el)? Cnil : p1->pathname.el)
1114
1131
@(defun enough_namestring (path
1115
1132
&o (defaults si_default_pathname_defaults()))
1133
cl_object newpath, pathdir, defaultdir, fname;
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
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. */
1150
cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir,
1151
@':test', @'equal');
1152
if (dir_begin == Cnil) {
1154
} else if (dir_begin == cl_length(defaultdir)) {
1155
pathdir = funcall(3, @'subseq', pathdir, dir_begin);
1156
pathdir = CONS(@':relative', pathdir);
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 */
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),
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))
1140
1173
/* --------------- PATHNAME MATCHING ------------------ */
1142
1175
static bool path_item_match(cl_object a, cl_object mask);
1145
do_path_item_match(const char *s, const char *p) {
1149
/* Match any group of characters */
1151
while (*s && *s != *next) s++;
1152
if (do_path_item_match(s,next))
1154
/* starts back from the '*' */
1158
} else if (*s != *p)
1178
do_path_item_match(cl_object s, cl_index j, cl_object p, cl_index i)
1180
cl_index ls = ecl_length(s), lp = ecl_length(p);
1183
cl_index cp = ecl_char(p, i);
1185
/* An asterisk in the patter matches any number
1186
* of characters. We try the shortest sequence
1188
cl_index cn = 0, next;
1190
next < lp && ((cn = ecl_char(p, next)) == '*');
1197
if (do_path_item_match(s, j, p, next)) {
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. */
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);
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') {
1236
while (!ecl_endp(a)) {
1189
1237
if (path_list_match(a, mask))
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')
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;
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,
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);
1268
1316
/* Find its translation list */
1269
1317
pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal');
1271
@(return ((pair == Cnil)? Cnil : CADR(pair)))
1318
if (set == OBJNULL) {
1319
@(return ((pair == Cnil)? Cnil : CADR(pair)));
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);
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));
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)
1293
cl_index i, j, k, ia, ib;
1340
cl_index i, j, k, ls, lm;
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';
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; ) {
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 == '*') {
1355
k < ls && ecl_char(source,k) != pattern_char;
1310
l = CONS(make_one(&a[i], k-i), l);
1358
l = CONS(make_one(source, i, k), l);
1362
if (ecl_char(source,i) != pattern_char)
1315
1363
return @':error';
1318
if (i < ia || j < ib)
1366
if (i < ls || j < lm)
1319
1367
return @':error';
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;
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;
1425
l = ecl_length(pattern);
1426
token = si_get_buffer_string();
1382
1427
for (j = i = 0; i < l; ) {
1428
cl_index c = ecl_char(pattern, i);
1388
push_c_string(cl_env.token, &s[j], i-j);
1434
push_substring(token, pattern, j, i);
1389
1436
new_string = TRUE;
1437
if (ecl_endp(wilds)) {
1391
1438
return @':error';
1392
push_string(cl_env.token, CAR(wilds));
1440
push_string(token, CAR(wilds));
1393
1441
wilds = CDR(wilds);
1396
1444
/* Only create a new string when needed */
1398
pattern = si_copy_to_simple_base_string(cl_env.token);
1446
if (ecl_fits_in_base_string(token)) {
1447
pattern = si_copy_to_simple_base_string(token);
1449
pattern = cl_copy_seq(token);
1452
si_put_buffer_string(token);
1399
1453
*wilds_list = wilds;
1400
1454
return pattern;