1/* Implementation of the GETENV g77, and
2   GET_ENVIRONMENT_VARIABLE F2003, intrinsics.
3   Copyright (C) 2004-2020 Free Software Foundation, Inc.
4   Contributed by Janne Blomqvist.
5
6This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8Libgfortran is free software; you can redistribute it and/or
9modify it under the terms of the GNU General Public
10License as published by the Free Software Foundation; either
11version 3 of the License, or (at your option) any later version.
12
13Libgfortran is distributed in the hope that it will be useful,
14but WITHOUT ANY WARRANTY; without even the implied warranty of
15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16GNU General Public License for more details.
17
18Under Section 7 of GPL version 3, you are granted additional
19permissions described in the GCC Runtime Library Exception, version
203.1, as published by the Free Software Foundation.
21
22You should have received a copy of the GNU General Public License and
23a copy of the GCC Runtime Library Exception along with this program;
24see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25<http://www.gnu.org/licenses/>.  */
26
27#include "libgfortran.h"
28#include <string.h>
29
30
31/* GETENV (NAME, VALUE), g77 intrinsic for retrieving the value of
32   an environment variable. The name of the variable is specified in
33   NAME, and the result is stored into VALUE.  */
34
35void PREFIX(getenv) (char *, char *, gfc_charlen_type, gfc_charlen_type);
36export_proto_np(PREFIX(getenv));
37
38void
39PREFIX(getenv) (char * name, char * value, gfc_charlen_type name_len,
40		gfc_charlen_type value_len)
41{
42  char *name_nt;
43  char *res = NULL;
44
45  if (name == NULL || value == NULL)
46    runtime_error ("Both arguments to getenv are mandatory.");
47
48  if (value_len < 1 || name_len < 1)
49    runtime_error ("Zero length string(s) passed to getenv.");
50  else
51    memset (value, ' ', value_len); /* Blank the string.  */
52
53  /* Make a null terminated copy of the string.  */
54  name_nt = fc_strdup (name, name_len);
55
56  res = getenv(name_nt);
57
58  free (name_nt);
59
60  /* If res is NULL, it means that the environment variable didn't
61     exist, so just return.  */
62  if (res == NULL)
63    return;
64
65  cf_strcpy (value, value_len, res);
66}
67
68
69/* GET_ENVIRONMENT_VARIABLE (name, [value, length, status, trim_name])
70   is a F2003 intrinsic for getting an environment variable.  */
71
72/* Status codes specifyed by the standard. */
73#define GFC_SUCCESS 0
74#define GFC_VALUE_TOO_SHORT -1
75#define GFC_NAME_DOES_NOT_EXIST 1
76
77/* This is also specified by the standard and means that the
78   processor doesn't support environment variables.  At the moment,
79   gfortran doesn't use it.  */
80#define GFC_NOT_SUPPORTED 2
81
82/* Processor-specific failure code.  */
83#define GFC_FAILURE 42
84
85extern void get_environment_variable_i4 (char *, char *, GFC_INTEGER_4 *,
86					 GFC_INTEGER_4 *, GFC_LOGICAL_4 *,
87					 gfc_charlen_type, gfc_charlen_type);
88iexport_proto(get_environment_variable_i4);
89
90void
91get_environment_variable_i4 (char *name, char *value, GFC_INTEGER_4 *length,
92			     GFC_INTEGER_4 *status, GFC_LOGICAL_4 *trim_name,
93			     gfc_charlen_type name_len,
94			     gfc_charlen_type value_len)
95{
96  int stat = GFC_SUCCESS;
97  gfc_charlen_type res_len = 0;
98  char *name_nt;
99  char *res;
100
101  if (name == NULL)
102    runtime_error ("Name is required for get_environment_variable.");
103
104  if (value == NULL && length == NULL && status == NULL && trim_name == NULL)
105    return;
106
107  if (name_len < 1)
108    runtime_error ("Zero-length string passed as name to "
109		   "get_environment_variable.");
110
111  if (value != NULL)
112    {
113      if (value_len > 0)
114	memset (value, ' ', value_len); /* Blank the string.  */
115    }
116
117  if ((!trim_name) || *trim_name)
118    name_nt = fc_strdup (name, name_len);
119  else
120    name_nt = fc_strdup_notrim (name, name_len);
121
122  res = getenv(name_nt);
123
124  free (name_nt);
125
126  if (res == NULL)
127    stat = GFC_NAME_DOES_NOT_EXIST;
128  else
129    {
130      res_len = strlen(res);
131      if (value != NULL)
132	{
133	  if (value_len < res_len)
134	    {
135	      memcpy (value, res, value_len);
136	      stat = GFC_VALUE_TOO_SHORT;
137	    }
138	  else if (res_len > 0)
139	    memcpy (value, res, res_len);
140	}
141    }
142
143  if (status != NULL)
144    *status = stat;
145
146  if (length != NULL)
147    *length = res_len;
148}
149iexport(get_environment_variable_i4);
150
151
152/* INTEGER*8 wrapper for get_environment_variable.  */
153
154extern void get_environment_variable_i8 (char *, char *, GFC_INTEGER_8 *,
155					 GFC_INTEGER_8 *, GFC_LOGICAL_8 *,
156					 gfc_charlen_type, gfc_charlen_type);
157export_proto(get_environment_variable_i8);
158
159void
160get_environment_variable_i8 (char *name, char *value, GFC_INTEGER_8 *length,
161			     GFC_INTEGER_8 *status, GFC_LOGICAL_8 *trim_name,
162			     gfc_charlen_type name_len,
163			     gfc_charlen_type value_len)
164{
165  GFC_INTEGER_4 length4, status4;
166  GFC_LOGICAL_4 trim_name4;
167
168  if (trim_name)
169    trim_name4 = *trim_name;
170
171  get_environment_variable_i4 (name, value, &length4, &status4,
172			       trim_name ? &trim_name4 : NULL,
173			       name_len, value_len);
174
175  if (length)
176    *length = length4;
177
178  if (status)
179    *status = status4;
180}
181