Annotation of OpenXM_contrib/PHC/Ada/System/communications_with_user.adb, Revision 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