This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
IRIX 64-bitness fixes.
[metaconfig.git] / U / modified / Getfile.U
CommitLineData
959f3c4c
JH
1?RCS: $Id: Getfile.U,v 3.0.1.7 1997/02/28 15:01:06 ram Exp $
2?RCS:
3?RCS: Copyright (c) 1991-1993, Raphael Manfredi
4?RCS:
5?RCS: You may redistribute only under the terms of the Artistic Licence,
6?RCS: as specified in the README file that comes with the distribution.
7?RCS: You may reuse parts of this distribution only within the terms of
8?RCS: that same Artistic Licence; a copy of which may be found at the root
9?RCS: of the source tree for dist 3.0.
10?RCS:
11?RCS: $Log: Getfile.U,v $
12?RCS: Revision 3.0.1.7 1997/02/28 15:01:06 ram
13?RCS: patch61: getfile script now begins with "startsh"
14?RCS:
15?RCS: Revision 3.0.1.6 1995/02/15 14:11:00 ram
16?RCS: patch51: was not working if ~'s allowed with d_portable on (WED)
17?RCS:
18?RCS: Revision 3.0.1.5 1995/01/11 15:11:25 ram
19?RCS: patch45: added support for escaping answers to skip various checks
20?RCS: patch45: modified message issued after file expansion
21?RCS:
22?RCS: Revision 3.0.1.4 1994/10/29 15:53:19 ram
23?RCS: patch36: added ?F: line for metalint file checking
24?RCS:
25?RCS: Revision 3.0.1.3 1994/05/06 14:23:36 ram
26?RCS: patch23: getfile could be confused by file name in "locate" requests
27?RCS: patch23: new 'p' directive to assume file is in people's path (WED)
28?RCS:
29?RCS: Revision 3.0.1.2 1994/01/24 14:01:31 ram
30?RCS: patch16: added metalint hint on changed 'ans' variable
31?RCS:
32?RCS: Revision 3.0.1.1 1993/09/13 15:46:27 ram
33?RCS: patch10: minor format problems and misspellings fixed
34?RCS: patch10: now performs from package dir and not from UU subdir
35?RCS:
36?RCS: Revision 3.0 1993/08/18 12:04:56 ram
37?RCS: Baseline for dist 3.0 netwide release.
38?RCS:
39?X:
40?X: This unit produces a bit of shell code that must be dotted in in order
41?X: to get a file name and make some sanity checks. Optionally, a ~name
42?X: expansion is performed.
43?X:
44?X: To use this unit, $rp and $dflt must hold the question and the
45?X: default answer, which will be passed as-is to the myread script.
46?X: The $fn variable must hold the file type (f or d, for file/directory).
47?X: If $gfpth is set to a list of space-separated list of directories,
48?X: those are prefixes for the filename. Unless $gfpthkeep is set to 'y',
49?X: gfpth is cleared on return from Getfile.
50?X:
51?X: If is is followed by a ~, then ~name substitution will occur. Upon return,
52?X: $ans is set with the filename value. If a / is specified, then only a full
53?X: path name is accepted (but ~ substitution occurs before, if needed). The
54?X: expanded path name is returned in that case.
55?X:
56?X: If a + is specified, the existence checks are skipped. This usually means
57?X: the file/directory is under the full control of the program.
58?X:
59?X: If the 'n' (none) type is used, then the user may answer none.
60?X: The 'e' (expand) switch may be used to bypass d_portable, expanding ~name.
61?X:
62?X: If the 'l' (locate) type is used, then it must end with a ':' and then a
63?X: file name. If the answer is a directory, the file name will be appended
64?X: before testing for file existence. This is useful in locate-style
65?X: questions like "where is the active file?". In that case, one should
66?X: use:
67?X:
68?X: dflt='~news/lib'
69?X: fn='l~:active'
70?X: rp='Where is the active file?'
71?X: . ./getfile
72?X: active="$ans"
73?X:
74?X: If the 'p' (path) letter is specified along with 'l', then an answer
75?X: without a leading / will be expected to be found in everyone's path.
76?X:
77?X: It is also possible to include a comma-separated list of items within
78?X: parentheses to specify which items should be accepted as-is with no
79?X: further checks. This is useful when for instance a full path is expected
80?X: but the user may escape out via "magical" answers.
81?X:
82?X: If the answer to the question is 'none', then the existence checks are
83?X: skipped and the empty string is returned.
84?X:
85?MAKE:Getfile: d_portable contains startsh Myread Filexp trnl
86?MAKE: -pick add $@ %<
87?V:ansexp:fn gfpth gfpthkeep
88?F:./getfile
89?T:tilde type what orig_rp orig_dflt fullpath already redo skip none_ok \
90 value exp_file nopath_ok loc_file fp pf
91?LINT:change ans
92?LINT:change gfpth
93: now set up to get a file name
94cat <<EOS >getfile
95$startsh
96EOS
97cat <<'EOSC' >>getfile
98tilde=''
99fullpath=''
100already=''
101skip=''
102none_ok=''
103exp_file=''
104nopath_ok=''
105orig_rp="$rp"
106orig_dflt="$dflt"
107case "$gfpth" in
108'') gfpth='.' ;;
109esac
110
111?X: Begin by stripping out any (...) grouping.
112case "$fn" in
113*\(*)
114 expr $fn : '.*(\(.*\)).*' | tr ',' $trnl >getfile.ok
115 fn=`echo $fn | sed 's/(.*)//'`
116 ;;
117esac
118
119?X: Catch up 'locate' requests early, so that we may strip the file name
120?X: before looking at the one-letter commands, in case the file name contains
121?X: one of them. Reported by Wayne Davison <davison@borland.com>.
122case "$fn" in
123*:*)
124 loc_file=`expr $fn : '.*:\(.*\)'`
125 fn=`expr $fn : '\(.*\):.*'`
126 ;;
127esac
128
129case "$fn" in
130*~*) tilde=true;;
131esac
132case "$fn" in
133*/*) fullpath=true;;
134esac
135case "$fn" in
136*+*) skip=true;;
137esac
138case "$fn" in
139*n*) none_ok=true;;
140esac
141case "$fn" in
142*e*) exp_file=true;;
143esac
144case "$fn" in
145*p*) nopath_ok=true;;
146esac
147
148case "$fn" in
149*f*) type='File';;
150*d*) type='Directory';;
151*l*) type='Locate';;
152esac
153
154what="$type"
155case "$what" in
156Locate) what='File';;
157esac
158
159case "$exp_file" in
160'')
161 case "$d_portable" in
162 "$define") ;;
163 *) exp_file=true;;
164 esac
165 ;;
166esac
167
168cd ..
169while test "$type"; do
170 redo=''
171 rp="$orig_rp"
172 dflt="$orig_dflt"
173 case "$tilde" in
174 true) rp="$rp (~name ok)";;
175 esac
176 . UU/myread
177?X: check for allowed escape sequence which may be accepted verbatim.
178 if test -f UU/getfile.ok && \
179 $contains "^$ans\$" UU/getfile.ok >/dev/null 2>&1
180 then
181 value="$ans"
182 ansexp="$ans"
183 break
184 fi
185 case "$ans" in
186 none)
187 value=''
188 ansexp=''
189 case "$none_ok" in
190 true) type='';;
191 esac
192 ;;
193 *)
194 case "$tilde" in
195 '') value="$ans"
196 ansexp="$ans";;
197 *)
198 value=`UU/filexp $ans`
199 case $? in
200 0)
201 if test "$ans" != "$value"; then
202 echo "(That expands to $value on this system.)"
203 fi
204 ;;
205 *) value="$ans";;
206 esac
207 ansexp="$value"
208 case "$exp_file" in
209 '') value="$ans";;
210 esac
211 ;;
212 esac
213 case "$fullpath" in
214 true)
215?X: Perform all the checks on ansexp and not value since when d_portable
216?X: is defined, the original un-expanded answer which is stored in value
217?X: would lead to "non-existent" error messages whilst ansexp has been
218?X: properly expanded. -- Fixed by Jan.Djarv@sa.erisoft.se (Jan Djarv)
219?X: Always expand ~user if '/' was requested
220 case "$ansexp" in
221 /*) value="$ansexp" ;;
222 *)
223 redo=true
224 case "$already" in
225 true)
226 echo "I shall only accept a full path name, as in /bin/ls." >&4
227 echo "Use a ! shell escape if you wish to check pathnames." >&4
228 ;;
229 *)
230 echo "Please give a full path name, starting with slash." >&4
231 case "$tilde" in
232 true)
233 echo "Note that using ~name is ok provided it expands well." >&4
234 already=true
235 ;;
236 esac
237 esac
238 ;;
239 esac
240 ;;
241 esac
242 case "$redo" in
243 '')
244 case "$type" in
245 File)
246 for fp in $gfpth; do
247 if test "X$fp" = X.; then
248 pf="$ansexp"
249 else
250 pf="$fp/$ansexp"
251 fi
252 if test -f "$pf"; then
253 type=''
254 elif test -r "$pf" || (test -h "$pf") >/dev/null 2>&1
255 then
256 echo "($value is not a plain file, but that's ok.)"
257 type=''
258 fi
259 if test X"$type" = X; then
260 value="$pf"
261 break
262 fi
263 done
264 ;;
265 Directory)
266 for fp in $gfpth; do
267 if test "X$fp" = X.; then
268 pf="$ansexp"
269 else
270 pf="$fp/$ansexp"
271 fi
272 if test -d "$pf"; then
273 type=''
274 value="$pf"
275 break
276 fi
277 done
278 ;;
279 Locate)
280 if test -d "$ansexp"; then
281 echo "(Looking for $loc_file in directory $value.)"
282 value="$value/$loc_file"
283 ansexp="$ansexp/$loc_file"
284 fi
285 if test -f "$ansexp"; then
286 type=''
287 fi
288 case "$nopath_ok" in
289 true) case "$value" in
290 */*) ;;
291 *) echo "Assuming $value will be in people's path."
292 type=''
293 ;;
294 esac
295 ;;
296 esac
297 ;;
298 esac
299
300 case "$skip" in
301 true) type='';
302 esac
303
304 case "$type" in
305 '') ;;
306 *)
307 if test "$fastread" = yes; then
308 dflt=y
309 else
310 dflt=n
311 fi
312 rp="$what $value doesn't exist. Use that name anyway?"
313 . UU/myread
314 dflt=''
315 case "$ans" in
316 y*) type='';;
317 *) echo " ";;
318 esac
319 ;;
320 esac
321 ;;
322 esac
323 ;;
324 esac
325done
326cd UU
327ans="$value"
328rp="$orig_rp"
329dflt="$orig_dflt"
330rm -f getfile.ok
331test "X$gfpthkeep" != Xy && gfpth=""
332EOSC
333