1/* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2   Contributed by Andy Vaught
3
4This file is part of the GNU Fortran runtime library (libgfortran).
5
6Libgfortran is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 3, or (at your option)
9any later version.
10
11Libgfortran is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14GNU General Public License for more details.
15
16Under Section 7 of GPL version 3, you are granted additional
17permissions described in the GCC Runtime Library Exception, version
183.1, as published by the Free Software Foundation.
19
20You should have received a copy of the GNU General Public License and
21a copy of the GCC Runtime Library Exception along with this program;
22see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
23<http://www.gnu.org/licenses/>.  */
24
25#include "libgfortran.h"
26
27#include <string.h>
28#include <strings.h>
29#include <ctype.h>
30
31#ifdef HAVE_UNISTD_H
32#include <unistd.h>
33#endif
34
35
36/* Implementation of secure_getenv() for targets where it is not
37   provided. */
38
39#ifdef FALLBACK_SECURE_GETENV
40
41#if SUPPORTS_WEAKREF && defined(HAVE___SECURE_GETENV)
42static char* weak_secure_getenv (const char*)
43  __attribute__((__weakref__("__secure_getenv")));
44#endif
45
46char *
47secure_getenv (const char *name)
48{
49#if SUPPORTS_WEAKREF && defined(HAVE___SECURE_GETENV)
50  if (weak_secure_getenv)
51    return weak_secure_getenv (name);
52#endif
53
54  if ((getuid () == geteuid ()) && (getgid () == getegid ()))
55    return getenv (name);
56  else
57    return NULL;
58}
59#endif
60
61
62
63/* Examine the environment for controlling aspects of the program's
64   execution.  Our philosophy here that the environment should not prevent
65   the program from running, so any invalid value will be ignored.  */
66
67
68options_t options;
69
70typedef struct variable
71{
72  const char *name;
73  int default_value;
74  int *var;
75  void (*init) (struct variable *);
76}
77variable;
78
79static void init_unformatted (variable *);
80
81
82/* Initialize an integer environment variable.  */
83
84static void
85init_integer (variable * v)
86{
87  char *p, *q;
88
89  p = getenv (v->name);
90  if (p == NULL)
91    return;
92
93  for (q = p; *q; q++)
94    if (!isdigit (*q) && (p != q || *q != '-'))
95      return;
96
97  *v->var = atoi (p);
98}
99
100
101/* Initialize a boolean environment variable. We only look at the first
102   letter of the value. */
103
104static void
105init_boolean (variable * v)
106{
107  char *p;
108
109  p = getenv (v->name);
110  if (p == NULL)
111    return;
112
113  if (*p == '1' || *p == 'Y' || *p == 'y')
114    *v->var = 1;
115  else if (*p == '0' || *p == 'N' || *p == 'n')
116    *v->var = 0;
117}
118
119
120/* Initialize a list output separator.  It may contain any number of spaces
121   and at most one comma.  */
122
123static void
124init_sep (variable * v)
125{
126  int seen_comma;
127  char *p;
128
129  p = getenv (v->name);
130  if (p == NULL)
131    goto set_default;
132
133  options.separator = p;
134  options.separator_len = strlen (p);
135
136  /* Make sure the separator is valid */
137
138  if (options.separator_len == 0)
139    goto set_default;
140  seen_comma = 0;
141
142  while (*p)
143    {
144      if (*p == ',')
145	{
146	  if (seen_comma)
147	    goto set_default;
148	  seen_comma = 1;
149	  p++;
150	  continue;
151	}
152
153      if (*p++ != ' ')
154	goto set_default;
155    }
156
157  return;
158
159set_default:
160  options.separator = " ";
161  options.separator_len = 1;
162}
163
164
165static variable variable_table[] = {
166
167  /* Unit number that will be preconnected to standard input */
168  { "GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
169    init_integer },
170
171  /* Unit number that will be preconnected to standard output */
172  { "GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
173    init_integer },
174
175  /* Unit number that will be preconnected to standard error */
176  { "GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
177    init_integer },
178
179  /* If TRUE, all output will be unbuffered */
180  { "GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean },
181
182  /* If TRUE, output to preconnected units will be unbuffered */
183  { "GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
184    init_boolean },
185
186  /* Whether to print filename and line number on runtime error */
187  { "GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean },
188
189  /* Print optional plus signs in numbers where permitted */
190  { "GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean },
191
192  /* Separator to use when writing list output */
193  { "GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep },
194
195  /* Set the default data conversion for unformatted I/O */
196  { "GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted },
197
198  /* Print out a backtrace if possible on runtime error */
199  { "GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace, init_boolean },
200
201  /* Buffer size for unformatted files.  */
202  { "GFORTRAN_UNFORMATTED_BUFFER_SIZE", 0, &options.unformatted_buffer_size,
203    init_integer },
204
205  /* Buffer size for formatted files.  */
206  { "GFORTRAN_FORMATTED_BUFFER_SIZE", 0, &options.formatted_buffer_size,
207    init_integer },
208
209  { NULL, 0, NULL, NULL }
210};
211
212
213/* Initialize most runtime variables from
214 * environment variables. */
215
216void
217init_variables (void)
218{
219  variable *v;
220
221  for (v = variable_table; v->name; v++)
222    {
223      if (v->var)
224	*v->var = v->default_value;
225      v->init (v);
226    }
227}
228
229
230/* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
231   It is called from environ.c to parse this variable, and from
232   open.c to determine if the user specified a default for an
233   unformatted file.
234   The syntax of the environment variable is, in bison grammar:
235
236   GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
237   mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
238   exception: mode ':' unit_list | unit_list ;
239   unit_list: unit_spec | unit_list unit_spec ;
240   unit_spec: INTEGER | INTEGER '-' INTEGER ;
241*/
242
243/* Defines for the tokens.  Other valid tokens are ',', ':', '-'.  */
244
245
246#define NATIVE   257
247#define SWAP     258
248#define BIG      259
249#define LITTLE   260
250/* Some space for additional tokens later.  */
251#define INTEGER  273
252#define END      (-1)
253#define ILLEGAL  (-2)
254
255typedef struct
256{
257  int unit;
258  unit_convert conv;
259} exception_t;
260
261
262static char *p;            /* Main character pointer for parsing.  */
263static char *lastpos;      /* Auxiliary pointer, for backing up.  */
264static int unit_num;       /* The last unit number read.  */
265static int unit_count;     /* The number of units found. */
266static int do_count;       /* Parsing is done twice - first to count the number
267			      of units, then to fill in the table.  This
268			      variable controls what to do.  */
269static exception_t *elist; /* The list of exceptions to the default. This is
270			      sorted according to unit number.  */
271static int n_elist;        /* Number of exceptions to the default.  */
272
273static unit_convert endian; /* Current endianness.  */
274
275static unit_convert def; /* Default as specified (if any).  */
276
277/* Search for a unit number, using a binary search.  The
278   first argument is the unit number to search for.  The second argument
279   is a pointer to an index.
280   If the unit number is found, the function returns 1, and the index
281   is that of the element.
282   If the unit number is not found, the function returns 0, and the
283   index is the one where the element would be inserted.  */
284
285static int
286search_unit (int unit, int *ip)
287{
288  int low, high, mid;
289
290  if (n_elist == 0)
291    {
292      *ip = 0;
293      return 0;
294    }
295
296  low = 0;
297  high = n_elist - 1;
298
299  do
300    {
301      mid = (low + high) / 2;
302      if (unit == elist[mid].unit)
303	{
304	  *ip = mid;
305	  return 1;
306	}
307      else if (unit > elist[mid].unit)
308	low = mid + 1;
309      else
310	high = mid - 1;
311    } while (low <= high);
312
313  if (unit > elist[mid].unit)
314    *ip = mid + 1;
315  else
316    *ip = mid;
317
318  return 0;
319}
320
321/* This matches a keyword.  If it is found, return the token supplied,
322   otherwise return ILLEGAL.  */
323
324static int
325match_word (const char *word, int tok)
326{
327  int res;
328
329  if (strncasecmp (p, word, strlen (word)) == 0)
330    {
331      p += strlen (word);
332      res = tok;
333    }
334  else
335    res = ILLEGAL;
336  return res;
337}
338
339/* Match an integer and store its value in unit_num.  This only works
340   if p actually points to the start of an integer.  The caller has
341   to ensure this.  */
342
343static int
344match_integer (void)
345{
346  unit_num = 0;
347  while (isdigit (*p))
348    unit_num = unit_num * 10 + (*p++ - '0');
349  return INTEGER;
350}
351
352/* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
353   Returned values are the different tokens.  */
354
355static int
356next_token (void)
357{
358  int result;
359
360  lastpos = p;
361  switch (*p)
362    {
363    case '\0':
364      result = END;
365      break;
366
367    case ':':
368    case ',':
369    case '-':
370    case ';':
371      result = *p;
372      p++;
373      break;
374
375    case 'b':
376    case 'B':
377      result = match_word ("big_endian", BIG);
378      break;
379
380    case 'l':
381    case 'L':
382      result = match_word ("little_endian", LITTLE);
383      break;
384
385    case 'n':
386    case 'N':
387      result = match_word ("native", NATIVE);
388      break;
389
390    case 's':
391    case 'S':
392      result = match_word ("swap", SWAP);
393      break;
394
395    case '1': case '2': case '3': case '4': case '5':
396    case '6': case '7': case '8': case '9':
397      result = match_integer ();
398      break;
399
400    default:
401      result = ILLEGAL;
402      break;
403    }
404  return result;
405}
406
407/* Back up the last token by setting back the character pointer.  */
408
409static void
410push_token (void)
411{
412  p = lastpos;
413}
414
415/* This is called when a unit is identified.  If do_count is nonzero,
416   increment the number of units by one.  If do_count is zero,
417   put the unit into the table.  */
418
419static void
420mark_single (int unit)
421{
422  int i,j;
423
424  if (do_count)
425    {
426      unit_count++;
427      return;
428    }
429  if (search_unit (unit, &i))
430    {
431      elist[i].conv = endian;
432    }
433  else
434    {
435      for (j=n_elist-1; j>=i; j--)
436	elist[j+1] = elist[j];
437
438      n_elist += 1;
439      elist[i].unit = unit;
440      elist[i].conv = endian;
441    }
442}
443
444/* This is called when a unit range is identified.  If do_count is
445   nonzero, increase the number of units.  If do_count is zero,
446   put the unit into the table.  */
447
448static void
449mark_range (int unit1, int unit2)
450{
451  int i;
452  if (do_count)
453    unit_count += abs (unit2 - unit1) + 1;
454  else
455    {
456      if (unit2 < unit1)
457	for (i=unit2; i<=unit1; i++)
458	  mark_single (i);
459      else
460	for (i=unit1; i<=unit2; i++)
461	  mark_single (i);
462    }
463}
464
465/* Parse the GFORTRAN_CONVERT_UNITS variable.  This is called
466   twice, once to count the units and once to actually mark them in
467   the table.  When counting, we don't check for double occurrences
468   of units.  */
469
470static int
471do_parse (void)
472{
473  int tok;
474  int unit1;
475  int continue_ulist;
476  char *start;
477
478  unit_count = 0;
479
480  start = p;
481
482  /* Parse the string.  First, let's look for a default.  */
483  tok = next_token ();
484  switch (tok)
485    {
486    case NATIVE:
487      endian = GFC_CONVERT_NATIVE;
488      break;
489
490    case SWAP:
491      endian = GFC_CONVERT_SWAP;
492      break;
493
494    case BIG:
495      endian = GFC_CONVERT_BIG;
496      break;
497
498    case LITTLE:
499      endian = GFC_CONVERT_LITTLE;
500      break;
501
502    case INTEGER:
503      /* A leading digit means that we are looking at an exception.
504	 Reset the position to the beginning, and continue processing
505	 at the exception list.  */
506      p = start;
507      goto exceptions;
508      break;
509
510    case END:
511      goto end;
512      break;
513
514    default:
515      goto error;
516      break;
517    }
518
519  tok = next_token ();
520  switch (tok)
521    {
522    case ';':
523      def = endian;
524      break;
525
526    case ':':
527      /* This isn't a default after all.  Reset the position to the
528	 beginning, and continue processing at the exception list.  */
529      p = start;
530      goto exceptions;
531      break;
532
533    case END:
534      def = endian;
535      goto end;
536      break;
537
538    default:
539      goto error;
540      break;
541    }
542
543 exceptions:
544
545  /* Loop over all exceptions.  */
546  while(1)
547    {
548      tok = next_token ();
549      switch (tok)
550	{
551	case NATIVE:
552	  if (next_token () != ':')
553	    goto error;
554	  endian = GFC_CONVERT_NATIVE;
555	  break;
556
557	case SWAP:
558	  if (next_token () != ':')
559	    goto error;
560	  endian = GFC_CONVERT_SWAP;
561	  break;
562
563	case LITTLE:
564	  if (next_token () != ':')
565	    goto error;
566	  endian = GFC_CONVERT_LITTLE;
567	  break;
568
569	case BIG:
570	  if (next_token () != ':')
571	    goto error;
572	  endian = GFC_CONVERT_BIG;
573	  break;
574
575	case INTEGER:
576	  push_token ();
577	  break;
578
579	case END:
580	  goto end;
581	  break;
582
583	default:
584	  goto error;
585	  break;
586	}
587      /* We arrive here when we want to parse a list of
588	 numbers.  */
589      continue_ulist = 1;
590      do
591	{
592	  tok = next_token ();
593	  if (tok != INTEGER)
594	    goto error;
595
596	  unit1 = unit_num;
597	  tok = next_token ();
598	  /* The number can be followed by a - and another number,
599	     which means that this is a unit range, a comma
600	     or a semicolon.  */
601	  if (tok == '-')
602	    {
603	      if (next_token () != INTEGER)
604		goto error;
605
606	      mark_range (unit1, unit_num);
607	      tok = next_token ();
608	      if (tok == END)
609		goto end;
610	      else if (tok == ';')
611		continue_ulist = 0;
612	      else if (tok != ',')
613		goto error;
614	    }
615	  else
616	    {
617	      mark_single (unit1);
618	      switch (tok)
619		{
620		case ';':
621		  continue_ulist = 0;
622		  break;
623
624		case ',':
625		  break;
626
627		case END:
628		  goto end;
629		  break;
630
631		default:
632		  goto error;
633		}
634	    }
635	} while (continue_ulist);
636    }
637 end:
638  return 0;
639 error:
640  def = GFC_CONVERT_NONE;
641  return -1;
642}
643
644void init_unformatted (variable * v)
645{
646  char *val;
647  val = getenv (v->name);
648  def = GFC_CONVERT_NONE;
649  n_elist = 0;
650
651  if (val == NULL)
652    return;
653  do_count = 1;
654  p = val;
655  do_parse ();
656  if (do_count <= 0)
657    {
658      n_elist = 0;
659      elist = NULL;
660    }
661  else
662    {
663      elist = xmallocarray (unit_count, sizeof (exception_t));
664      do_count = 0;
665      p = val;
666      do_parse ();
667    }
668}
669
670/* Get the default conversion for for an unformatted unit.  */
671
672unit_convert
673get_unformatted_convert (int unit)
674{
675  int i;
676
677  if (elist == NULL)
678    return def;
679  else if (search_unit (unit, &i))
680    return elist[i].conv;
681  else
682    return def;
683}
684