libgfortran/runtime/environ.c

   1 /* Copyright (C) 2002-2021 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 3, or (at your option)
   9 any later version.
  10
  11 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 Under Section 7 of GPL version 3, you are granted additional
  17 permissions described in the GCC Runtime Library Exception, version
  18 3.1, as published by the Free Software Foundation.
  19
  20 You should have received a copy of the GNU General Public License and
  21 a copy of the GCC Runtime Library Exception along with this program;
  22 see 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)
  42 static char* weak_secure_getenv (const char*)
  43   __attribute__((__weakref__("__secure_getenv")));
  44 #endif
  45
  46 char *
  47 secure_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
  68 options_t options;
  69
  70 typedef struct variable
  71 {
  72   const char *name;
  73   int default_value;
  74   int *var;
  75   void (*init) (struct variable *);
  76 }
  77 variable;
  78
  79 static void init_unformatted (variable *);
  80
  81
  82 /* Initialize an integer environment variable.  */
  83
  84 static void
  85 init_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
 104 static void
 105 init_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
 123 static void
 124 init_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
 159 set_default:
 160   options.separator = " ";
 161   options.separator_len = 1;
 162 }
 163
 164
 165 static 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
 216 void
 217 init_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
 255 typedef struct
 256 {
 257   int unit;
 258   unit_convert conv;
 259 } exception_t;
 260
 261
 262 static char *p;            /* Main character pointer for parsing.  */
 263 static char *lastpos;      /* Auxiliary pointer, for backing up.  */
 264 static int unit_num;       /* The last unit number read.  */
 265 static int unit_count;     /* The number of units found. */
 266 static 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.  */
 269 static exception_t *elist; /* The list of exceptions to the default. This is
 270                               sorted according to unit number.  */
 271 static int n_elist;        /* Number of exceptions to the default.  */
 272
 273 static unit_convert endian; /* Current endianness.  */
 274
 275 static 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
 285 static int
 286 search_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
 324 static int
 325 match_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
 343 static int
 344 match_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
 355 static int
 356 next_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
 409 static void
 410 push_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
 419 static void
 420 mark_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
 448 static void
 449 mark_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
 470 static int
 471 do_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
 644 void 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
 672 unit_convert
 673 get_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 }