home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / g-os_lib.adb < prev    next >
Text File  |  1996-09-28  |  12KB  |  422 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                          G N A T . O S _ L I B                           --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.27 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Unchecked_Conversion;
  27. with System;                  use System;
  28. with System.Storage_Elements; use System.Storage_Elements;
  29.  
  30. package body GNAT.OS_Lib is
  31.  
  32.    -----------------------
  33.    -- Local Subprograms --
  34.    -----------------------
  35.  
  36.    function C_String_Length (S : Address) return Integer;
  37.    --  Returns the length of a C string.  Does check for null address
  38.    --  (returns 0).
  39.  
  40.    ---------------------
  41.    -- C_String_Length --
  42.    ---------------------
  43.  
  44.    function C_String_Length (S : Address) return Integer is
  45.       function Strlen (S : Address) return Integer;
  46.       pragma Import (C, Strlen, "strlen");
  47.  
  48.    begin
  49.       if S = Null_Address then
  50.          return 0;
  51.       else
  52.          return Strlen (S);
  53.       end if;
  54.    end C_String_Length;
  55.  
  56.    ----------------------
  57.    -- Create_Temp_File --
  58.    ----------------------
  59.  
  60.    procedure Create_Temp_File
  61.      (FD   : out File_Descriptor;
  62.       Name : out Temp_File_Name)
  63.    is
  64.       function Get_Temp_Name (T : Address) return Address;
  65.       pragma Import (C, Get_Temp_Name, "mktemp");
  66.  
  67.       Result : Address;
  68.  
  69.    begin
  70.       Name := "GNAT-XXXXXX" & Ascii.NUL;
  71.  
  72.       --  Check for NULL pointer returned by C
  73.  
  74.       if Get_Temp_Name (Name'Address) = To_Address (0) then
  75.          FD := -1;
  76.       else
  77.          FD := Create_New_File (Name'Address, Binary);
  78.       end if;
  79.    end Create_Temp_File;
  80.  
  81.    -----------------
  82.    -- Delete_File --
  83.    -----------------
  84.  
  85.    procedure Delete_File (Name : Address; Success : out Boolean) is
  86.       R : Integer;
  87.  
  88.       function unlink (A : Address) return Integer;
  89.       pragma Import (C, unlink, "unlink");
  90.  
  91.    begin
  92.       R := unlink (Name);
  93.       Success := (R = 0);
  94.    end Delete_File;
  95.  
  96.    ----------------------
  97.    -- File_Time_Stamp  --
  98.    ----------------------
  99.  
  100.    function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
  101.       function File_Time (FD    : File_Descriptor) return OS_Time;
  102.       pragma Import (C, File_Time, "file_time_fd");
  103.  
  104.    begin
  105.       return File_Time (FD);
  106.    end File_Time_Stamp;
  107.  
  108.    ----------------------
  109.    -- File_Time_Stamp  --
  110.    ----------------------
  111.  
  112.    function File_Time_Stamp (Name : String) return OS_Time is
  113.  
  114.       function File_Time (Name : Address) return OS_Time;
  115.       pragma Import (C, File_Time, "file_time_name");
  116.  
  117.       F_Name : String (1 .. Name'Last + 1);
  118.  
  119.    begin
  120.       F_Name (Name'Range) := Name;
  121.       F_Name (F_Name'Last) := Ascii.NUL;
  122.       return File_Time (F_Name'Address);
  123.    end File_Time_Stamp;
  124.  
  125.    ------------
  126.    -- Getenv --
  127.    ------------
  128.  
  129.    function Getenv (Name : String) return String_Access is
  130.  
  131.       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
  132.       pragma Import (C, Get_Env_Value_Ptr, "get_env_value_ptr");
  133.  
  134.       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
  135.       pragma Import (C, Strncpy, "strncpy");
  136.  
  137.       Env_Value_Ptr    : Address;
  138.       Env_Value_Length : Integer;
  139.       F_Name           : String (1 .. Name'Last + 1);
  140.       Result           : String_Access;
  141.  
  142.    begin
  143.       F_Name (Name'Range) := Name;
  144.       F_Name (F_Name'Last) := Ascii.NUL;
  145.  
  146.       Get_Env_Value_Ptr
  147.         (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
  148.  
  149.       Result := new String (1 .. Env_Value_Length);
  150.  
  151.       if Env_Value_Length > 0 then
  152.          Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
  153.       end if;
  154.  
  155.       return Result;
  156.    end Getenv;
  157.  
  158.    ------------
  159.    -- GM_Day --
  160.    ------------
  161.  
  162.    function GM_Day (Date : OS_Time) return Day_Type is
  163.       Y  : Year_Type;
  164.       Mo : Month_Type;
  165.       D  : Day_Type;
  166.       H  : Hour_Type;
  167.       Mn : Minute_Type;
  168.       S  : Second_Type;
  169.  
  170.    begin
  171.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  172.       return D;
  173.    end GM_Day;
  174.  
  175.    -------------
  176.    -- GM_Hour --
  177.    -------------
  178.  
  179.    function GM_Hour (Date : OS_Time) return Hour_Type is
  180.       Y  : Year_Type;
  181.       Mo : Month_Type;
  182.       D  : Day_Type;
  183.       H  : Hour_Type;
  184.       Mn : Minute_Type;
  185.       S  : Second_Type;
  186.  
  187.    begin
  188.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  189.       return H;
  190.    end GM_Hour;
  191.  
  192.    ---------------
  193.    -- GM_Minute --
  194.    ---------------
  195.  
  196.    function GM_Minute (Date : OS_Time) return Minute_Type is
  197.       Y  : Year_Type;
  198.       Mo : Month_Type;
  199.       D  : Day_Type;
  200.       H  : Hour_Type;
  201.       Mn : Minute_Type;
  202.       S  : Second_Type;
  203.  
  204.    begin
  205.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  206.       return Mn;
  207.    end GM_Minute;
  208.  
  209.    --------------
  210.    -- GM_Month --
  211.    --------------
  212.  
  213.    function GM_Month (Date : OS_Time) return Month_Type is
  214.       Y  : Year_Type;
  215.       Mo : Month_Type;
  216.       D  : Day_Type;
  217.       H  : Hour_Type;
  218.       Mn : Minute_Type;
  219.       S  : Second_Type;
  220.  
  221.    begin
  222.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  223.       return Mo;
  224.    end GM_Month;
  225.  
  226.    ---------------
  227.    -- GM_Second --
  228.    ---------------
  229.  
  230.    function GM_Second (Date : OS_Time) return Second_Type is
  231.       Y  : Year_Type;
  232.       Mo : Month_Type;
  233.       D  : Day_Type;
  234.       H  : Hour_Type;
  235.       Mn : Minute_Type;
  236.       S  : Second_Type;
  237.  
  238.    begin
  239.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  240.       return S;
  241.    end GM_Second;
  242.  
  243.    --------------
  244.    -- GM_Split --
  245.    --------------
  246.  
  247.    procedure GM_Split
  248.      (Date   : OS_Time;
  249.       Year   : out Year_Type;
  250.       Month  : out Month_Type;
  251.       Day    : out Day_Type;
  252.       Hour   : out Hour_Type;
  253.       Minute : out Minute_Type;
  254.       Second : out Second_Type)
  255.    is
  256.       procedure To_GM_Time
  257.         (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
  258.       pragma Import (C, To_GM_Time, "to_gm_time");
  259.  
  260.       T  : OS_Time := Date;
  261.       Y  : Integer;
  262.       Mo : Integer;
  263.       D  : Integer;
  264.       H  : Integer;
  265.       Mn : Integer;
  266.       S  : Integer;
  267.  
  268.    begin
  269.       To_GM_Time (T'Address, Y'Address, Mo'Address, D'Address, H'Address,
  270.                   Mn'Address, S'Address);
  271.       Year   := Y + 1900;
  272.       Month  := Mo + 1;
  273.       Day    := D;
  274.       Hour   := H;
  275.       Minute := Mn;
  276.       Second := S;
  277.    end GM_Split;
  278.  
  279.    -------------
  280.    -- GM_Year --
  281.    -------------
  282.  
  283.    function GM_Year (Date : OS_Time) return Year_Type is
  284.       Y  : Year_Type;
  285.       Mo : Month_Type;
  286.       D  : Day_Type;
  287.       H  : Hour_Type;
  288.       Mn : Minute_Type;
  289.       S  : Second_Type;
  290.  
  291.    begin
  292.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  293.       return Y;
  294.    end GM_Year;
  295.  
  296.    ------------------
  297.    -- Is_Directory --
  298.    ------------------
  299.  
  300.    function Is_Directory (Name : String) return Boolean is
  301.  
  302.       function Is_Directory (Name : Address) return Integer;
  303.       pragma Import (C, Is_Directory, "is_directory");
  304.  
  305.       F_Name : String (1 .. Name'Last + 1);
  306.  
  307.    begin
  308.       F_Name (Name'Range) := Name;
  309.       F_Name (F_Name'Last) := Ascii.NUL;
  310.       return Is_Directory (F_Name'Address) /= 0;
  311.    end Is_Directory;
  312.  
  313.    ---------------------
  314.    -- Is_Regular_File --
  315.    ---------------------
  316.  
  317.    function Is_Regular_File (Name : String) return Boolean is
  318.  
  319.       function Is_Regular_File (Name : Address) return Integer;
  320.       pragma Import (C, Is_Regular_File, "is_regular_file");
  321.  
  322.       F_Name : String (1 .. Name'Last + 1);
  323.  
  324.    begin
  325.       F_Name (Name'Range) := Name;
  326.       F_Name (F_Name'Last) := Ascii.NUL;
  327.       return Is_Regular_File (F_Name'Address) /= 0;
  328.    end Is_Regular_File;
  329.  
  330.    -------------------------
  331.    -- Locate_Regular_File --
  332.    -------------------------
  333.  
  334.    function Locate_Regular_File
  335.      (File_Name : String;
  336.       Path      : String)
  337.       return      String_Access
  338.    is
  339.       function Locate_Exec (Exec_Name, Path_Val : Address) return Address;
  340.       pragma Import (C, Locate_Exec, "locate_exec");
  341.  
  342.       --  "historical reasons" for the name of the C function. ???
  343.  
  344.       Exec_Name  : String (1 .. File_Name'Length + 1);
  345.       Path_Val   : String (1 .. Path'Length);
  346.       Path_Addr  : Address;
  347.       Path_Len   : Integer;
  348.       Return_Val : String_Access;
  349.  
  350.    begin
  351.       Exec_Name (1 .. File_Name'Length) := File_Name;
  352.       Exec_Name (Exec_Name'Last)        := Ascii.NUL;
  353.       Path_Val  (1 .. Path'Length)      := Path;
  354.       Path_Val  (Path_Val'Last)         := Ascii.NUL;
  355.  
  356.       Path_Addr := Locate_Exec (Exec_Name'Address, Path_Val'Address);
  357.       Path_Len  := C_String_Length (Path_Addr);
  358.  
  359.       if Path_Len = 0 then
  360.          return null;
  361.       else
  362.          Return_Val := new String (1 .. Path_Len);
  363.  
  364.          declare
  365.             subtype Path_String is String (1 .. Path_Len);
  366.             type    Path_String_Access is access Path_String;
  367.             function Address_To_Access is new
  368.               Unchecked_Conversion (Source => Address,
  369.                                     Target => Path_String_Access);
  370.             Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
  371.  
  372.          begin
  373.             for J in 1 .. Path_Len loop
  374.                Return_Val (J) := Path_Access (J);
  375.             end loop;
  376.  
  377.             return Return_Val;
  378.          end;
  379.       end if;
  380.    end Locate_Regular_File;
  381.  
  382.    -----------
  383.    -- Spawn --
  384.    -----------
  385.  
  386.    procedure Spawn
  387.      (Program_Name : String;
  388.       Args         : Argument_List;
  389.       Success      : out Boolean)
  390.    is
  391.       Arg_List : array (1 .. Args'Length + 2) of Address;
  392.  
  393.       Arg : String_Access;
  394.  
  395.       function Portable_Spawn (Args : Address) return Integer;
  396.       pragma Import (C, Portable_Spawn, "portable_spawn");
  397.  
  398.    begin
  399.       Arg := new String (1 .. Program_Name'Length + 1);
  400.       Arg (1 .. Program_Name'Length) := Program_Name;
  401.       Arg (Arg'Last)                 := Ascii.NUL;
  402.       Arg_List (1)                   := Arg.all'Address;
  403.  
  404.       for J in 1 .. Args'Length loop
  405.          Arg := new String (1 .. Args (J + Args'First - 1)'Length + 1);
  406.          Arg (1 .. Arg'Last - 1) := Args (J + Args'First - 1).all;
  407.          Arg (Arg'Last) := Ascii.NUL;
  408.          Arg_List (J + 1) := Arg.all'Address;
  409.       end loop;
  410.  
  411.       Arg_List (Arg_List'Last) := Null_Address;
  412.  
  413.       if Portable_Spawn (Arg_List'Address) = 0 then
  414.          Success := True;
  415.       else
  416.          Success := False;
  417.       end if;
  418.  
  419.    end Spawn;
  420.  
  421. end GNAT.OS_Lib;
  422.