1  /* Implementation of the HOSTNM intrinsic.
       2     Copyright (C) 2005-2023 Free Software Foundation, Inc.
       3     Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
       4  
       5  This file is part of the GNU Fortran runtime library (libgfortran).
       6  
       7  Libgfortran is free software; you can redistribute it and/or
       8  modify it under the terms of the GNU General Public
       9  License as published by the Free Software Foundation; either
      10  version 3 of the License, or (at your option) any later version.
      11  
      12  Libgfortran is distributed in the hope that it will be useful,
      13  but WITHOUT ANY WARRANTY; without even the implied warranty of
      14  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      15  GNU General Public License for more details.
      16  
      17  Under Section 7 of GPL version 3, you are granted additional
      18  permissions described in the GCC Runtime Library Exception, version
      19  3.1, as published by the Free Software Foundation.
      20  
      21  You should have received a copy of the GNU General Public License and
      22  a copy of the GCC Runtime Library Exception along with this program;
      23  see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
      24  <http://www.gnu.org/licenses/>.  */
      25  
      26  #include "libgfortran.h"
      27  
      28  #include <errno.h>
      29  #include <string.h>
      30  
      31  #ifdef HAVE_UNISTD_H
      32  #include <unistd.h> 
      33  #endif
      34  
      35  #include <limits.h>
      36  
      37  #ifndef HOST_NAME_MAX
      38  #define HOST_NAME_MAX 255
      39  #endif
      40  
      41  
      42  /* Windows32 version */
      43  #if defined __MINGW32__ && !defined  HAVE_GETHOSTNAME
      44  #define WIN32_LEAN_AND_MEAN
      45  #include <windows.h>
      46  #include <errno.h>
      47  
      48  static int
      49  w32_gethostname (char *name, size_t len)
      50  {
      51    /* We could try the WinSock API gethostname, but that will
      52       fail if WSAStartup function has has not been called.  We don't
      53      really need a name that will be understood by socket API, so avoid
      54      unnecessary dependence on WinSock libraries by using
      55      GetComputerName instead.  */
      56  
      57    /* On Win9x GetComputerName fails if the input size is less
      58       than MAX_COMPUTERNAME_LENGTH + 1.  */
      59    char buffer[MAX_COMPUTERNAME_LENGTH + 1];
      60    DWORD size =  sizeof (buffer);
      61  
      62    if (!GetComputerName (buffer, &size))
      63      return -1;
      64  
      65    if ((size = strlen (buffer) + 1)  > len)
      66      {
      67        errno = EINVAL;
      68        /* Truncate as per POSIX spec.  We do not NUL-terminate. */
      69        size = len;
      70      }
      71    memcpy (name, buffer, (size_t) size);
      72  
      73    return 0;
      74  }
      75  
      76  #undef gethostname
      77  #define gethostname w32_gethostname
      78  #define  HAVE_GETHOSTNAME 1
      79  
      80  #endif
      81  
      82  
      83  /* SUBROUTINE HOSTNM(NAME, STATUS)
      84     CHARACTER(len=*), INTENT(OUT) :: NAME
      85     INTEGER, INTENT(OUT), OPTIONAL :: STATUS  */
      86  
      87  #ifdef HAVE_GETHOSTNAME
      88  static int
      89  hostnm_0 (char *name, gfc_charlen_type name_len)
      90  {
      91    char p[HOST_NAME_MAX + 1];
      92    int val;
      93  
      94    memset (name, ' ', name_len);
      95  
      96    size_t reqlen = sizeof (p) > (size_t) name_len + 1
      97      ? (size_t) name_len + 1: sizeof (p);
      98    val = gethostname (p, reqlen);
      99  
     100    if (val == 0)
     101    {
     102      for (gfc_charlen_type i = 0; i < name_len && p[i] != '\0'; i++)
     103        name[i] = p[i];
     104    }
     105  
     106    return ((val == 0) ? 0 : errno);
     107  }
     108  
     109  extern void hostnm_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type);
     110  iexport_proto(hostnm_i4_sub);
     111  
     112  void
     113  hostnm_i4_sub (char *name, GFC_INTEGER_4 *status, gfc_charlen_type name_len)
     114  {
     115    int val = hostnm_0 (name, name_len);
     116    if (status != NULL) 
     117      *status = val;
     118  }
     119  iexport(hostnm_i4_sub);
     120  
     121  extern void hostnm_i8_sub (char *, GFC_INTEGER_8 *, gfc_charlen_type);
     122  iexport_proto(hostnm_i8_sub);
     123  
     124  void
     125  hostnm_i8_sub (char *name, GFC_INTEGER_8 *status, gfc_charlen_type name_len)
     126  {
     127    int val = hostnm_0 (name, name_len);
     128    if (status != NULL) 
     129      *status = val;
     130  }
     131  iexport(hostnm_i8_sub);
     132  
     133  extern GFC_INTEGER_4 hostnm (char *, gfc_charlen_type);
     134  export_proto(hostnm);
     135  
     136  GFC_INTEGER_4
     137  hostnm (char *name, gfc_charlen_type name_len)
     138  {
     139    return hostnm_0 (name, name_len);
     140  }
     141  #endif