libgfortran/runtime/environ.c

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