home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / TKERMIT.LBR / KOPEN.PQS / KOPEN.PAS
Pascal/Delphi Source File  |  2000-06-30  |  5KB  |  104 lines
  1. (*--------------------------------------------------------------------*)
  2.  
  3.   procedure open_file(file_mode : f_modes; fileref : string15);
  4.  
  5.     (* This procedure attempts to open a file for writing or reading
  6.        using standard Turbo Pascal procedures.  If the file is opened
  7.        successfully, open_ok is returned, and file_open is returned true
  8.     *)
  9.  
  10.     var
  11.       count, space_pos : integer;
  12.       drive : string1;
  13.       temp_fn : string[20];
  14.       filename : string[15];
  15.       filetype : string[3];
  16.  
  17.     procedure open_for_write(fileref : string15; var open_ok : boolean);
  18.  
  19.       (* On an open for write, if reset is successful, the file already
  20.          exists.  In this version, we never want to destroy an existing
  21.          file, so the file is never rewritten
  22.       *)
  23.  
  24.       begin
  25.         assign(outfile, fileref); (* assign filvar *)
  26.         {$I-} (* turn off io checking *)
  27.         reset(outfile); (* try to open it *)
  28.         {$I+} (* allow error checking again *)
  29.         if ioresult <> 0 then (* 0 for open, not 0 for not found *)
  30.           begin  (* filename is new file, open it *)
  31.             rewrite(outfile);
  32.             file_records := filesize(outfile); (* get the size of the file *)
  33.             open_ok := true; (* flags for calling procedure *)
  34.             file_open := true;
  35.             buffer_num := 0; (* we are at the first buffer of data *)
  36.           end
  37.         else
  38.           open_ok := false; (* The file already existed *)
  39.       end;
  40.  
  41.     begin (* open_file *)
  42.       case file_mode of
  43.         read_open : begin
  44.                       assign(outfile, fileref); (* try to open file *)
  45.                       {$I-}
  46.                       reset(outfile);
  47.                       {$I+}
  48.                       if ioresult = 0 then (* yes, it exists *)
  49.                         begin
  50.                           open_ok := true;
  51.                           file_open := true;
  52.                           file_records := filesize(outfile);
  53.                           gotoxy(62,7); (* display filesize for progress report *)
  54.                           write((file_records * 128):6);
  55.                           buffer_num := 0;
  56.                         end
  57.                       else  (* couldn't open file *)
  58.                         begin
  59.                           open_ok := false;
  60.                           gotoxy(1,8);
  61.                           write('File ', fileref, ' does not exist.');
  62.                         end;
  63.                     end;
  64.         write_open : begin
  65.                        open_for_write(fileref, open_ok); (* try on entry *)
  66.                        if not open_ok then
  67.                           (* File already existed, so we'll try to build a
  68.                              unique filename for the file and open that. For
  69.                              reasons I don't remember, it will only try to
  70.                              insert '&' signs until all the unfilled
  71.                              character positions in the filename are used up.
  72.                              The original filename will always be present.
  73.                           *)
  74.  
  75.                          begin
  76.                            temp_fn := fileref;
  77.                            repeat
  78.                              adjust_fn(temp_fn, drive, filename, filetype);
  79.                              temp_fn := filename + '.' + filetype;
  80.                              if drive <> '!' then
  81.                                temp_fn := drive + ':' + temp_fn;
  82.                              space_pos := pos(' ',temp_fn);
  83.                              if space_pos <> 0 then
  84.                                begin
  85.                                  delete(temp_fn,space_pos,1);
  86.                                  insert('&',temp_fn,space_pos);
  87.                                  while pos(' ',temp_fn) <> 0 do
  88.                                    delete(temp_fn,pos(' ',temp_fn),1);
  89.                                  open_for_write(temp_fn, open_ok);
  90.                                end;
  91.                            until (open_ok) or (space_pos = 0);
  92.                            gotoxy(1,9);
  93.                            if open_ok then (* print the new filename *)
  94.                              if (temp_fn <> fileref) then
  95.                                write('Filename ',fileref, ' changed to: ', temp_fn)
  96.                              else
  97.                                write('Filename: ',temp_fn)
  98.                            else
  99.                              write('Filename ', fileref, ' could not be opened.');
  100.                          end;
  101.                      end;
  102.       end; (* case *)
  103.     end; (* open_file *)
  104.