1 |
14 |
jlechner |
/* Implementation of the GETENV g77, and
|
2 |
|
|
GET_ENVIRONMENT_VARIABLE F2003, intrinsics.
|
3 |
|
|
Copyright (C) 2004 Free Software Foundation, Inc.
|
4 |
|
|
Contributed by Janne Blomqvist.
|
5 |
|
|
|
6 |
|
|
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
7 |
|
|
|
8 |
|
|
Libgfortran is free software; you can redistribute it and/or
|
9 |
|
|
modify it under the terms of the GNU General Public
|
10 |
|
|
License as published by the Free Software Foundation; either
|
11 |
|
|
version 2 of the License, or (at your option) any later version.
|
12 |
|
|
|
13 |
|
|
In addition to the permissions in the GNU General Public License, the
|
14 |
|
|
Free Software Foundation gives you unlimited permission to link the
|
15 |
|
|
compiled version of this file into combinations with other programs,
|
16 |
|
|
and to distribute those combinations without any restriction coming
|
17 |
|
|
from the use of this file. (The General Public License restrictions
|
18 |
|
|
do apply in other respects; for example, they cover modification of
|
19 |
|
|
the file, and distribution when not linked into a combine
|
20 |
|
|
executable.)
|
21 |
|
|
|
22 |
|
|
Libgfortran is distributed in the hope that it will be useful,
|
23 |
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
24 |
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
25 |
|
|
GNU General Public License for more details.
|
26 |
|
|
|
27 |
|
|
You should have received a copy of the GNU General Public
|
28 |
|
|
License along with libgfortran; see the file COPYING. If not,
|
29 |
|
|
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
30 |
|
|
Boston, MA 02110-1301, USA. */
|
31 |
|
|
|
32 |
|
|
#include "config.h"
|
33 |
|
|
#include <sys/types.h>
|
34 |
|
|
#include <stdlib.h>
|
35 |
|
|
#include <string.h>
|
36 |
|
|
#include "libgfortran.h"
|
37 |
|
|
|
38 |
|
|
|
39 |
|
|
/* GETENV (NAME, VALUE), g77 intrinsic for retrieving the value of
|
40 |
|
|
an environment variable. The name of the variable is specified in
|
41 |
|
|
NAME, and the result is stored into VALUE. */
|
42 |
|
|
|
43 |
|
|
void PREFIX(getenv) (char *, char *, gfc_charlen_type, gfc_charlen_type);
|
44 |
|
|
export_proto_np(PREFIX(getenv));
|
45 |
|
|
|
46 |
|
|
void
|
47 |
|
|
PREFIX(getenv) (char * name, char * value, gfc_charlen_type name_len,
|
48 |
|
|
gfc_charlen_type value_len)
|
49 |
|
|
{
|
50 |
|
|
char *name_nt;
|
51 |
|
|
char *res = NULL;
|
52 |
|
|
int res_len;
|
53 |
|
|
|
54 |
|
|
if (name == NULL || value == NULL)
|
55 |
|
|
runtime_error ("Both arguments to getenv are mandatory.");
|
56 |
|
|
|
57 |
|
|
if (value_len < 1 || name_len < 1)
|
58 |
|
|
runtime_error ("Zero length string(s) passed to getenv.");
|
59 |
|
|
else
|
60 |
|
|
memset (value, ' ', value_len); /* Blank the string. */
|
61 |
|
|
|
62 |
|
|
/* Trim trailing spaces from name. */
|
63 |
|
|
while (name_len > 0 && name[name_len - 1] == ' ')
|
64 |
|
|
name_len--;
|
65 |
|
|
|
66 |
|
|
/* Make a null terminated copy of the string. */
|
67 |
|
|
name_nt = gfc_alloca (name_len + 1);
|
68 |
|
|
memcpy (name_nt, name, name_len);
|
69 |
|
|
name_nt[name_len] = '\0';
|
70 |
|
|
|
71 |
|
|
res = getenv(name_nt);
|
72 |
|
|
|
73 |
|
|
/* If res is NULL, it means that the environment variable didn't
|
74 |
|
|
exist, so just return. */
|
75 |
|
|
if (res == NULL)
|
76 |
|
|
return;
|
77 |
|
|
|
78 |
|
|
res_len = strlen(res);
|
79 |
|
|
if (value_len < res_len)
|
80 |
|
|
memcpy (value, res, value_len);
|
81 |
|
|
else
|
82 |
|
|
memcpy (value, res, res_len);
|
83 |
|
|
}
|
84 |
|
|
|
85 |
|
|
|
86 |
|
|
/* GET_ENVIRONMENT_VARIABLE (name, [value, length, status, trim_name])
|
87 |
|
|
is a F2003 intrinsic for getting an environment variable. */
|
88 |
|
|
|
89 |
|
|
/* Status codes specifyed by the standard. */
|
90 |
|
|
#define GFC_SUCCESS 0
|
91 |
|
|
#define GFC_VALUE_TOO_SHORT -1
|
92 |
|
|
#define GFC_NAME_DOES_NOT_EXIST 1
|
93 |
|
|
|
94 |
|
|
/* This is also specified by the standard and means that the
|
95 |
|
|
processor doesn't support environment variables. At the moment,
|
96 |
|
|
gfortran doesn't use it. */
|
97 |
|
|
#define GFC_NOT_SUPPORTED 2
|
98 |
|
|
|
99 |
|
|
/* Processor-specific failure code. */
|
100 |
|
|
#define GFC_FAILURE 42
|
101 |
|
|
|
102 |
|
|
extern void get_environment_variable_i4 (char *, char *, GFC_INTEGER_4 *,
|
103 |
|
|
GFC_INTEGER_4 *, GFC_LOGICAL_4 *,
|
104 |
|
|
gfc_charlen_type, gfc_charlen_type);
|
105 |
|
|
iexport_proto(get_environment_variable_i4);
|
106 |
|
|
|
107 |
|
|
void
|
108 |
|
|
get_environment_variable_i4 (char *name, char *value, GFC_INTEGER_4 *length,
|
109 |
|
|
GFC_INTEGER_4 *status, GFC_LOGICAL_4 *trim_name,
|
110 |
|
|
gfc_charlen_type name_len,
|
111 |
|
|
gfc_charlen_type value_len)
|
112 |
|
|
{
|
113 |
|
|
int stat = GFC_SUCCESS, res_len = 0;
|
114 |
|
|
char *name_nt;
|
115 |
|
|
char *res;
|
116 |
|
|
|
117 |
|
|
if (name == NULL)
|
118 |
|
|
runtime_error ("Name is required for get_environment_variable.");
|
119 |
|
|
|
120 |
|
|
if (value == NULL && length == NULL && status == NULL && trim_name == NULL)
|
121 |
|
|
return;
|
122 |
|
|
|
123 |
|
|
if (name_len < 1)
|
124 |
|
|
runtime_error ("Zero-length string passed as name to "
|
125 |
|
|
"get_environment_variable.");
|
126 |
|
|
|
127 |
|
|
if (value != NULL)
|
128 |
|
|
{
|
129 |
|
|
if (value_len < 1)
|
130 |
|
|
runtime_error ("Zero-length string passed as value to "
|
131 |
|
|
"get_environment_variable.");
|
132 |
|
|
else
|
133 |
|
|
memset (value, ' ', value_len); /* Blank the string. */
|
134 |
|
|
}
|
135 |
|
|
|
136 |
|
|
if ((!trim_name) || *trim_name)
|
137 |
|
|
{
|
138 |
|
|
/* Trim trailing spaces from name. */
|
139 |
|
|
while (name_len > 0 && name[name_len - 1] == ' ')
|
140 |
|
|
name_len--;
|
141 |
|
|
}
|
142 |
|
|
/* Make a null terminated copy of the name. */
|
143 |
|
|
name_nt = gfc_alloca (name_len + 1);
|
144 |
|
|
memcpy (name_nt, name, name_len);
|
145 |
|
|
name_nt[name_len] = '\0';
|
146 |
|
|
|
147 |
|
|
res = getenv(name_nt);
|
148 |
|
|
|
149 |
|
|
if (res == NULL)
|
150 |
|
|
stat = GFC_NAME_DOES_NOT_EXIST;
|
151 |
|
|
else
|
152 |
|
|
{
|
153 |
|
|
res_len = strlen(res);
|
154 |
|
|
if (value != NULL)
|
155 |
|
|
{
|
156 |
|
|
if (value_len < res_len)
|
157 |
|
|
{
|
158 |
|
|
memcpy (value, res, value_len);
|
159 |
|
|
stat = GFC_VALUE_TOO_SHORT;
|
160 |
|
|
}
|
161 |
|
|
else
|
162 |
|
|
memcpy (value, res, res_len);
|
163 |
|
|
}
|
164 |
|
|
}
|
165 |
|
|
|
166 |
|
|
if (status != NULL)
|
167 |
|
|
*status = stat;
|
168 |
|
|
|
169 |
|
|
if (length != NULL)
|
170 |
|
|
*length = res_len;
|
171 |
|
|
}
|
172 |
|
|
iexport(get_environment_variable_i4);
|
173 |
|
|
|
174 |
|
|
|
175 |
|
|
/* INTEGER*8 wrapper for get_environment_variable. */
|
176 |
|
|
|
177 |
|
|
extern void get_environment_variable_i8 (char *, char *, GFC_INTEGER_8 *,
|
178 |
|
|
GFC_INTEGER_8 *, GFC_LOGICAL_8 *,
|
179 |
|
|
gfc_charlen_type, gfc_charlen_type);
|
180 |
|
|
export_proto(get_environment_variable_i8);
|
181 |
|
|
|
182 |
|
|
void
|
183 |
|
|
get_environment_variable_i8 (char *name, char *value, GFC_INTEGER_8 *length,
|
184 |
|
|
GFC_INTEGER_8 *status, GFC_LOGICAL_8 *trim_name,
|
185 |
|
|
gfc_charlen_type name_len,
|
186 |
|
|
gfc_charlen_type value_len)
|
187 |
|
|
{
|
188 |
|
|
GFC_INTEGER_4 length4, status4;
|
189 |
|
|
GFC_LOGICAL_4 trim_name4;
|
190 |
|
|
|
191 |
|
|
if (trim_name)
|
192 |
|
|
trim_name4 = *trim_name;
|
193 |
|
|
|
194 |
|
|
get_environment_variable_i4 (name, value, &length4, &status4,
|
195 |
|
|
&trim_name4, name_len, value_len);
|
196 |
|
|
|
197 |
|
|
if (length)
|
198 |
|
|
*length = length4;
|
199 |
|
|
|
200 |
|
|
if (status)
|
201 |
|
|
*status = status4;
|
202 |
|
|
}
|