Annotation of OpenXM_contrib/PHC/Ada/System/communications_with_user.adb, Revision 1.1.1.1
1.1 maekawa 1: package body Communications_with_User is
2:
3: -- AUXILIARY :
4:
5: function Is_In ( s : string; ch : character ) return boolean is
6:
7: -- DESCRIPTION :
8: -- Returns true if the character occurs in the string, false otherwise.
9:
10: begin
11: for i in s'range loop
12: if s(i) = ch
13: then return true;
14: end if;
15: end loop;
16: return false;
17: end Is_In;
18:
19: -- TARGET ROUTINES :
20:
21: function Read_String return string is
22:
23: temp : string(1..80);
24: cnt : natural;
25:
26: begin
27: put("Give a string of characters : ");
28: get_line(temp,cnt);
29: return temp(1..cnt);
30: end Read_String;
31:
32: procedure Ask ( ans : out character ) is
33:
34: ch : character;
35:
36: begin
37: loop
38: get(ch); skip_line;
39: exit when Valid_Alternative(ch);
40: put("Invalid alternative. Please try again : ");
41: end loop;
42: ans := ch;
43: end Ask;
44:
45: procedure Ask_Yes_or_No ( ans : out character ) is
46:
47: function Yes_or_No ( alt : character ) return boolean is
48: begin
49: if alt = 'y' or else alt = 'n'
50: then return true;
51: else return false;
52: end if;
53: end Yes_or_No;
54: procedure Yes_or_No_Ask is new Ask (Yes_or_No);
55:
56: begin
57: Yes_or_No_Ask(ans);
58: end Ask_Yes_or_No;
59:
60: procedure Ask_Alternative ( ans : out character; alternatives : in string ) is
61:
62: function Is_Valid ( alt : character ) return boolean is
63: begin
64: return Is_In(alternatives,alt);
65: end Is_Valid;
66: procedure Ask_Alt is new Ask ( Is_Valid );
67:
68: begin
69: Ask_Alt(ans);
70: end Ask_Alternative;
71:
72: procedure Ask_Alternative
73: ( ans : in out string; alternatives : string;
74: prefix : in character ) is
75:
76: ok : boolean := false;
77: tmp : string(1..10);
78: ind,cnt : natural;
79:
80: begin
81: loop
82: get_line(tmp,cnt);
83: ans := " ";
84: ind := 1;
85: while (ans(1) = ' ') and (ind <= cnt) loop
86: ans(1) := tmp(ind);
87: ind := ind+1;
88: end loop;
89: if ans(1) = prefix
90: then while (ans(2) = ' ') and (ind <= cnt) loop
91: ans(2) := tmp(ind);
92: ind := ind+1;
93: end loop;
94: if Is_In(alternatives,ans(2))
95: then ok := true;
96: else put("Invalid alternative. Please try again : ");
97: end if;
98: else if Is_In(alternatives,ans(1))
99: then ok := true;
100: else put("Invalid alternative. Please try again : ");
101: end if;
102: end if;
103: exit when ok;
104: end loop;
105: end Ask_Alternative;
106:
107: procedure Read_Name_and_Open_File ( file : in out file_type ) is
108:
109: name : constant string := Read_String;
110:
111: begin
112: Open(file,in_file,name);
113: exception
114: when NAME_ERROR =>
115: put_line("The file could not be located, please try again...");
116: Read_Name_and_Open_File(file);
117: when USE_ERROR =>
118: put_line("File is not readable, please try again...");
119: Read_Name_and_Open_File(file);
120: end Read_Name_and_Open_File;
121:
122: procedure Read_Name_and_Create_File ( file : in out file_type ) is
123:
124: filename : constant string := Read_String;
125: ans : character;
126: temp : file_type;
127:
128: procedure Retry is
129: begin
130: Create(file,out_file,filename);
131: exception
132: when USE_ERROR =>
133: put_line("Could not create file, file already in use.");
134: put_line("Please, try again...");
135: Read_Name_and_Create_File(file);
136: when NAME_ERROR =>
137: put_line("Could not create file, perhaps wrong directory ?");
138: put_line("Please, try again...");
139: Read_Name_and_Create_File(file);
140: end Retry;
141:
142: begin
143: Open(temp,in_file,filename);
144: Close(temp);
145: put("There exists already a file named "); put_line(filename);
146: put("Do you want to destroy this file ? (y/n) ");
147: Ask_Yes_or_No(ans);
148: if ans = 'y'
149: then create(file,out_file,filename);
150: else Read_Name_and_Create_File(file);
151: end if;
152: exception
153: when others => Retry;
154: end Read_Name_and_Create_File;
155:
156: procedure Open_Input_File
157: ( file : in out file_type; filename : in string ) is
158: begin
159: Open(file,in_file,filename);
160: exception
161: when NAME_ERROR =>
162: put("The file "); put(filename);
163: put_line(" could not be located, please try again...");
164: Read_Name_and_Open_File(file);
165: when USE_ERROR =>
166: put("The file "); put(filename);
167: put_line(" is not readable, please try again...");
168: Read_Name_and_Open_File(file);
169: end Open_Input_File;
170:
171: procedure Create_Output_File
172: ( file : in out file_type; filename : in string ) is
173:
174: ans : character;
175: temp : file_type;
176:
177: procedure Retry is
178: begin
179: Create(file,out_file,filename);
180: exception
181: when USE_ERROR =>
182: put("Could not create file "); put(filename);
183: put_line(", file already in use.");
184: put_line("Please, try again...");
185: Read_Name_and_Create_File(file);
186: when NAME_ERROR =>
187: put("Could not create file "); put(filename);
188: put_line(", perhaps wrong directory ?");
189: put_line("Please, try again...");
190: Read_Name_and_Create_File(file);
191: end Retry;
192:
193: begin
194: if filename = ""
195: then new_line;
196: put_line("Reading the name of the output file.");
197: Read_Name_and_Create_File(file);
198: else Open(temp,in_file,filename); Close(temp);
199: new_line;
200: put("There exists already a file named "); put_line(filename);
201: put("Do you want to destroy this file ? (y/n) ");
202: Ask_Yes_or_No(ans);
203: if ans = 'y'
204: then create(file,out_file,filename);
205: else Read_Name_and_Create_File(file);
206: end if;
207: end if;
208: exception
209: when others => Retry;
210: end Create_Output_File;
211:
212: end Communications_with_User;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to communications_with_user.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / System