Patchwork [Ada] Handle VMS RMS keys in file I/O

login
register
mail settings
Submitter Arnaud Charlet
Date April 12, 2013, 12:58 p.m.
Message ID <20130412125820.GA16322@adacore.com>
Download mbox | patch
Permalink /patch/236083/
State New
Headers show

Comments

Arnaud Charlet - April 12, 2013, 12:58 p.m.
VMS has a multitude of sophisticated file organizations, formats,
and attributes that are handled at the system service level (aka RMS)
Under some circumstances a file can be created that cannot be read
without the appropriate RMS key in the file open call. A mechanism is
designed for passing RMS keys and a minimal number are implemented.

Tested on x86_64-pc-linux-gnu, committed on trunk

2013-04-12  Doug Rupp  <rupp@adacore.com>

	* s-crtl.ads (fopen, freopen): Add vms_form parameter
	* i-cstrea.ads (fopen, freopen): Likewise.
	* adaint.h (__gnat_fopen, __gnat_freopen): Likewise.
	* adaint.c (__gnat_fopen, __gnat_freopen): Likewise.
	[VMS]: Split out RMS keys and call CRTL function appropriately.
	* s-fileio.adb (Form_VMS_RMS_Keys, Form_RMS_Context_Key): New
	subprograms.
	(Open, Reset): Call Form_VMS_RMS_Keys. Call fopen,freopen with
	vms_form
	* gnat_rm.texi: Document implemented RMS keys.

Patch

Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi	(revision 197899)
+++ gnat_rm.texi	(working copy)
@@ -14261,6 +14261,25 @@ 
 unrecognized keyword appears in a form string, it is silently ignored
 and not considered invalid.
 
+@noindent
+For OpenVMS additional FORM string keywords are available for use with
+RMS services.  The syntax is:
+
+@smallexample
+VMS_RMS_Keys=(keyword=value,@dots{},keyword=value)
+@end smallexample
+
+@noindent
+The following RMS keywords and values are currently defined:
+
+@smallexample
+Context=Force_Stream_Mode|Force_Record_Mode
+@end smallexample
+
+@noindent
+VMS RMS keys are silently ignored on non-VMS systems.  On OpenVMS
+unimplented RMS keywords, values, or invalid syntax will raise Use_Error.
+
 @node Direct_IO
 @section Direct_IO
 
Index: s-crtl.ads
===================================================================
--- s-crtl.ads	(revision 197899)
+++ s-crtl.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2003-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 2003-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -97,7 +97,8 @@ 
    function fopen
      (filename : chars;
       mode     : chars;
-      encoding : Filename_Encoding := Unspecified) return FILEs;
+      encoding : Filename_Encoding := Unspecified;
+      vms_form : chars := System.Null_Address) return FILEs;
    pragma Import (C, fopen, "__gnat_fopen");
 
    function fputc (C : int; stream : FILEs) return int;
@@ -113,7 +114,8 @@ 
      (filename : chars;
       mode     : chars;
       stream   : FILEs;
-      encoding : Filename_Encoding := Unspecified) return FILEs;
+      encoding : Filename_Encoding := Unspecified;
+      vms_form : chars := System.Null_Address) return FILEs;
    pragma Import (C, freopen, "__gnat_freopen");
 
    function fseek
Index: i-cstrea.ads
===================================================================
--- i-cstrea.ads	(revision 197899)
+++ i-cstrea.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1995-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1995-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -107,8 +107,8 @@ 
    function fopen
      (filename : chars;
       mode     : chars;
-      encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8)
-      return FILEs
+      encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8;
+      vms_form : chars := System.Null_Address) return FILEs
      renames System.CRTL.fopen;
    --  Note: to maintain target independence, use text_translation_required,
    --  a boolean variable defined in sysdep.c to deal with the target
@@ -144,8 +144,8 @@ 
      (filename : chars;
       mode     : chars;
       stream   : FILEs;
-      encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8)
-      return FILEs
+      encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8;
+      vms_form : chars := System.Null_Address) return FILEs
      renames System.CRTL.freopen;
 
    function fseek
Index: adaint.c
===================================================================
--- adaint.c	(revision 197899)
+++ adaint.c	(working copy)
@@ -6,7 +6,7 @@ 
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 1992-2012, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2013, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -213,6 +213,8 @@ 
 
 #define SYI$_ACTIVECPU_CNT 0x111e
 extern int LIB$GETSYI (int *, unsigned int *);
+extern unsigned int LIB$CALLG_64
+ ( unsigned long long argument_list [], int (*user_procedure)(void));
 
 #else
 #include <utime.h>
@@ -820,7 +822,8 @@ 
 }
 
 FILE *
-__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
+__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED,
+              char *vms_form ATTRIBUTE_UNUSED)
 {
 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
   TCHAR wpath[GNAT_MAX_PATH_LEN];
@@ -837,7 +840,37 @@ 
 
   return _tfopen (wpath, wmode);
 #elif defined (VMS)
-  return decc$fopen (path, mode);
+  if (vms_form == 0)
+    return decc$fopen (path, mode);
+  else
+    {
+       char *local_form = (char *) alloca (strlen (vms_form) + 1);
+       /* Allocate an argument list of guaranteed ample length.  */
+       unsigned long long *arg_list =
+        (unsigned long long *) alloca (strlen (vms_form) + 3);
+       char *ptrb, *ptre;
+       int i;
+
+       arg_list [1] = (unsigned long long) path;
+       arg_list [2] = (unsigned long long) mode;
+       strcpy (local_form, vms_form);
+
+       /* Given a string such as "\"rfm=udf\",\"rat=cr\""
+          Split it into an argument list as "rfm=udf","rat=cr".  */
+       ptrb = local_form;
+       for (i = 0; *ptrb; i++)
+         {
+            ptrb = strchr (ptrb, '"');
+            ptre = strchr (ptrb + 1, '"');
+            *ptre = 0;
+            arg_list [i + 3] = (unsigned long long) (ptrb + 1);
+            ptrb = ptre + 1;
+         }
+       arg_list [0] = i + 2;
+       /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
+          always a 32bit pointer.   */
+       return LIB$CALLG_64 (arg_list, &decc$fopen);
+    }
 #else
   return GNAT_FOPEN (path, mode);
 #endif
@@ -847,7 +880,8 @@ 
 __gnat_freopen (char *path,
 		char *mode,
 		FILE *stream,
-		int encoding ATTRIBUTE_UNUSED)
+		int encoding ATTRIBUTE_UNUSED,
+                char *vms_form ATTRIBUTE_UNUSED)
 {
 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
   TCHAR wpath[GNAT_MAX_PATH_LEN];
@@ -864,7 +898,38 @@ 
 
   return _tfreopen (wpath, wmode, stream);
 #elif defined (VMS)
-  return decc$freopen (path, mode, stream);
+  if (vms_form == 0)
+    return decc$freopen (path, mode, stream);
+  else
+    {
+       char *local_form = (char *) alloca (strlen (vms_form) + 1);
+       /* Allocate an argument list of guaranteed ample length.  */
+       unsigned long long *arg_list =
+        (unsigned long long *) alloca (strlen (vms_form) + 4);
+       char *ptrb, *ptre;
+       int i;
+
+       arg_list [1] = (unsigned long long) path;
+       arg_list [2] = (unsigned long long) mode;
+       arg_list [3] = (unsigned long long) stream;
+       strcpy (local_form, vms_form);
+
+       /* Given a string such as "\"rfm=udf\",\"rat=cr\""
+          Split it into an argument list as "rfm=udf","rat=cr".  */
+       ptrb = local_form;
+       for (i = 0; *ptrb; i++)
+         {
+            ptrb = strchr (ptrb, '"');
+            ptre = strchr (ptrb + 1, '"');
+            *ptre = 0;
+            arg_list [i + 4] = (unsigned long long) (ptrb + 1);
+            ptrb = ptre + 1;
+         }
+       arg_list [0] = i + 3;
+       /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
+          always a 32bit pointer.   */
+       return LIB$CALLG_64 (arg_list, &decc$freopen);
+    }
 #else
   return freopen (path, mode, stream);
 #endif
Index: adaint.h
===================================================================
--- adaint.h	(revision 197899)
+++ adaint.h	(working copy)
@@ -6,7 +6,7 @@ 
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2012, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2013, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -128,9 +128,10 @@ 
 extern int    __gnat_chdir                         (char *);
 extern int    __gnat_rmdir                         (char *);
 
-extern FILE  *__gnat_fopen			   (char *, char *, int);
+extern FILE  *__gnat_fopen			   (char *, char *, int,
+						    char *);
 extern FILE  *__gnat_freopen			   (char *, char *, FILE *,
-				                    int);
+				                    int, char *);
 extern int    __gnat_open_read                     (char *, int);
 extern int    __gnat_open_rw                       (char *, int);
 extern int    __gnat_open_create                   (char *, int);
Index: s-fileio.adb
===================================================================
--- s-fileio.adb	(revision 197899)
+++ s-fileio.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -52,6 +52,11 @@ 
    use type Interfaces.C.int;
    use type CRTL.size_t;
 
+   subtype String_Access is System.OS_Lib.String_Access;
+   procedure Free (X : in out String_Access) renames System.OS_Lib.Free;
+   function "=" (X, Y : String_Access) return Boolean
+     renames System.OS_Lib."=";
+
    ----------------------
    -- Global Variables --
    ----------------------
@@ -98,6 +103,9 @@ 
      (C, text_translation_required, "__gnat_text_translation_required");
    --  If true, add appropriate suffix to control string for Open
 
+   VMS_Formstr : String_Access := null;
+   --  For special VMS RMS keywords and values.
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -132,11 +140,20 @@ 
    --  with Name includes that file name in the message.
 
    procedure Raise_Device_Error
-     (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno);
+     (File  : AFCB_Ptr;
+      Errno : Integer := OS_Lib.Errno);
    pragma No_Return (Raise_Device_Error);
    --  Clear error indication on File and raise Device_Error with an exception
    --  message providing errno information.
 
+   procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access);
+   --   Parse the RMS Keys
+
+   function Form_RMS_Context_Key
+     (Form     : String;
+      VMS_Form : String_Access) return Natural;
+   --   Parse the RMS Context Key
+
    ----------------
    -- Append_Set --
    ----------------
@@ -640,6 +657,191 @@ 
       Stop  := 0;
    end Form_Parameter;
 
+   --------------------------
+   -- Form_RMS_Context_Key --
+   --------------------------
+
+   function Form_RMS_Context_Key
+     (Form     : String;
+      VMS_Form : String_Access) return Natural
+   is
+      type Context_Parms is
+        (Binary_Data, Convert_Fortran_Carriage_Control, Force_Record_Mode,
+         Force_Stream_Mode, Explicit_Write);
+   --  Ada-fied list of all possible Context keyword values.
+
+      Pos   : Natural := 0;
+      Klen  : Natural := 0;
+      Index : Natural;
+
+   begin
+      --  Find the end of the occupation
+
+      for J in VMS_Form'First .. VMS_Form'Last loop
+         if VMS_Form (J) = ASCII.NUL then
+            Pos := J;
+            exit;
+         end if;
+      end loop;
+
+      Index := Form'First;
+      while Index < Form'Last loop
+         if Form (Index) = '=' then
+            Index := Index + 1;
+
+            --  Loop through the context values and look for a match
+
+            for Parm in Context_Parms loop
+               declare
+                  KImage : String := Context_Parms'Image (Parm);
+
+               begin
+                  Klen := KImage'Length;
+                  To_Lower (KImage);
+
+                  if Form (Index .. Index + Klen - 1) = KImage then
+                     case Parm is
+                        when Force_Record_Mode =>
+                           VMS_Form (Pos) := '"';
+                           Pos := Pos + 1;
+                           VMS_Form (Pos .. Pos + 7) := "ctx=rec";
+                           Pos := Pos + 7;
+                           VMS_Form (Pos) := '"';
+                           Pos := Pos + 1;
+                           VMS_Form (Pos) := ',';
+                           return Index + Klen;
+
+                        when Force_Stream_Mode =>
+                           VMS_Form (Pos) := '"';
+                           Pos := Pos + 1;
+                           VMS_Form (Pos .. Pos + 7) := "ctx=stm";
+                           Pos := Pos + 7;
+                           VMS_Form (Pos) := '"';
+                           Pos := Pos + 1;
+                           VMS_Form (Pos) := ',';
+                           return Index + Klen;
+
+                        when others =>
+                           raise Use_Error
+                             with "unimplemented RMS Context Value";
+                     end case;
+                  end if;
+               end;
+            end loop;
+
+            raise Use_Error with "unrecognized RMS Context Value";
+         end if;
+      end loop;
+
+      raise Use_Error with "malformed RMS Context Value";
+   end Form_RMS_Context_Key;
+
+   -----------------------
+   -- Form_VMS_RMS_Keys --
+   -----------------------
+
+   procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access)
+   is
+      VMS_RMS_Keys_Token : constant String := "vms_rms_keys";
+      Klen : Natural := VMS_RMS_Keys_Token'Length;
+      Index : Natural;
+
+      --  Ada-fied list of all RMS keywords, translated from the
+      --  HP C Run-Time Library Reference Manual, Table REF-3:
+      --  RMS Valid Keywords and Values
+
+      type RMS_Keys is
+       (Access_Callback, Allocation_Quantity, Block_Size, Context,
+        Default_Extension_Quantity, Default_File_Name_String, Error_Callback,
+        File_Processing_Options, Fixed_Header_Size, Global_Buffer_Count,
+        Multiblock_Count, Multibuffer_Count, Maximum_Record_Size,
+        Terminal_Input_Prompt, Record_Attributes, Record_Format,
+        Record_Processing_Options, Retrieval_Pointer_Count, Sharing_Options,
+        Timeout_IO_Value);
+
+   begin
+      Index := Form'First + Klen - 1;
+      while Index < Form'Last loop
+         Index := Index + 1;
+
+         --  Scan for the token signalling VMS RMS Keys ahead.  Should
+         --  whitespace be eaten???
+
+         if Form (Index - Klen .. Index - 1) = VMS_RMS_Keys_Token then
+
+            --  Allocate the VMS form string that will contain the cryptic
+            --  CRTL RMS strings and initialize it to all nulls.  Since the
+            --  CRTL strings are always shorter than the Ada-fied strings,
+            --  it follows that an allocation of the original size will be
+            --  more than adequate.
+            VMS_Form := new String'(Form (Form'First .. Form'Last));
+            VMS_Form.all := (others => ASCII.NUL);
+
+            if Form (Index) = '=' then
+               Index := Index + 1;
+               if Form (Index) = '(' then
+                  while Index < Form'Last loop
+                     Index := Index + 1;
+
+                     --  Loop through the RMS Keys and dispatch.
+
+                     for Key in RMS_Keys loop
+                        declare
+                           KImage : String := RMS_Keys'Image (Key);
+                        begin
+                           Klen := KImage'Length;
+                           To_Lower (KImage);
+                           if Form (Index .. Index + Klen - 1) = KImage then
+                              case Key is
+
+                                 when Context =>
+                                    Index := Form_RMS_Context_Key
+                                     (Form (Index + Klen .. Form'Last),
+                                      VMS_Form);
+                                    exit;
+
+                                 when others =>
+                                    raise Use_Error
+                                     with "unimplemented VMS RMS Form Key";
+                              end case;
+                           end if;
+                        end;
+                     end loop;
+
+                     if Form (Index) = ')' then
+
+                        --  Done, erase the unneeded trailing comma and
+                        --  return.
+
+                        for J in reverse VMS_Form'First .. VMS_Form'Last loop
+                           if VMS_Form (J) = ',' then
+                              VMS_Form (J) := ASCII.NUL;
+                              return;
+                           end if;
+                        end loop;
+
+                        --  Shouldn't be possible to get here
+                        raise Use_Error;
+
+                     elsif Form (Index) = ',' then
+
+                        --  Another key ahead, exit inner loop
+                        null;
+                     else
+
+                        --  Keyword value not terminated correctly
+                        raise Use_Error with "malformed VMS RMS Form";
+                     end if;
+                  end loop;
+               end if;
+            end if;
+
+            --  Found the keyword, but not followed by correct syntax
+            raise Use_Error with "malformed VMS RMS Form";
+         end if;
+      end loop;
+   end Form_VMS_RMS_Keys;
+
    -------------
    -- Is_Open --
    -------------
@@ -868,6 +1070,17 @@ 
            Form_Boolean (Formstr, "text_translation", Default => True);
       end if;
 
+      --  Acquire settings of target specific form parameters on VMS. Only
+      --  Context is currently implemented, for forcing a byte stream mode
+      --  read. On non-VMS systems, the settings are ultimately ignored in
+      --  the implementation of __gnat_fopen.
+
+      --  Should a warning be issued on non-VMS systems?  That's not possible
+      --  without testing System.OpenVMS boolean which isn't present in most
+      --  non-VMS versions of package System.
+
+      Form_VMS_RMS_Keys (Formstr, VMS_Formstr);
+
       --  If we were given a stream (call from xxx.C_Streams.Open), then set
       --  the full name to the given one, and skip to end of processing.
 
@@ -1030,8 +1243,20 @@ 
             --  since by the time of the delete, the current working directory
             --  may have changed and we do not want to delete a different file!
 
-            Stream := fopen (Namestr'Address, Fopstr'Address, Encoding);
+            if VMS_Formstr = null then
+               Stream := fopen (Namestr'Address, Fopstr'Address, Encoding,
+                                Null_Address);
+            else
+               Stream := fopen (Namestr'Address, Fopstr'Address, Encoding,
+                                VMS_Formstr.all'Address);
+            end if;
 
+            --   No need to keep this around
+
+            if VMS_Formstr /= null then
+               Free (VMS_Formstr);
+            end if;
+
             if Stream = NULL_Stream then
 
                --  Raise Name_Error if trying to open a non-existent file.
@@ -1042,15 +1267,15 @@ 
                declare
                   function Is_File_Not_Found_Error
                     (Errno_Value : Integer) return Integer;
-                  --  Non-zero when the given errno value indicates a non-
-                  --  existing file.
-
                   pragma Import
                     (C, Is_File_Not_Found_Error,
                      "__gnat_is_file_not_found_error");
+                  --  Non-zero when the given errno value indicates a non-
+                  --  existing file.
 
-                  Errno : constant Integer := OS_Lib.Errno;
+                  Errno   : constant Integer := OS_Lib.Errno;
                   Message : constant String := Errno_Message (Name, Errno);
+
                begin
                   if Is_File_Not_Found_Error (Errno) /= 0 then
                      raise Name_Error with Message;
@@ -1196,9 +1421,22 @@ 
          Fopen_Mode
            (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
 
-         File.Stream := freopen
-           (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding);
+         Form_VMS_RMS_Keys (File.Form.all, VMS_Formstr);
 
+         if VMS_Formstr = null then
+            File.Stream := freopen
+              (File.Name.all'Address, Fopstr'Address, File.Stream,
+               File.Encoding, Null_Address);
+         else
+            File.Stream := freopen
+              (File.Name.all'Address, Fopstr'Address, File.Stream,
+               File.Encoding, VMS_Formstr.all'Address);
+         end if;
+
+         if VMS_Formstr /= null then
+            Free (VMS_Formstr);
+         end if;
+
          if File.Stream = NULL_Stream then
             Close (File_Ptr);
             raise Use_Error;