libgfortran/runtime/environ.c

   1 /* Copyright (C) 2002-2018 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   { NULL, 0, NULL, NULL }
 202 };
 203
 204
 205 /* Initialize most runtime variables from
 206  * environment variables. */
 207
 208 void
 209 init_variables (void)
 210 {
 211   variable *v;
 212
 213   for (v = variable_table; v->name; v++)
 214     {
 215       if (v->var)
 216         *v->var = v->default_value;
 217       v->init (v);
 218     }
 219 }
 220
 221
 222 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
 223    It is called from environ.c to parse this variable, and from
 224    open.c to determine if the user specified a default for an
 225    unformatted file.
 226    The syntax of the environment variable is, in bison grammar:
 227
 228    GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
 229    mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
 230    exception: mode ':' unit_list | unit_list ;
 231    unit_list: unit_spec | unit_list unit_spec ;
 232    unit_spec: INTEGER | INTEGER '-' INTEGER ;
 233 */
 234
 235 /* Defines for the tokens.  Other valid tokens are ',', ':', '-'.  */
 236
 237
 238 #define NATIVE   257
 239 #define SWAP     258
 240 #define BIG      259
 241 #define LITTLE   260
 242 /* Some space for additional tokens later.  */
 243 #define INTEGER  273
 244 #define END      (-1)
 245 #define ILLEGAL  (-2)
 246
 247 typedef struct
 248 {
 249   int unit;
 250   unit_convert conv;
 251 } exception_t;
 252
 253
 254 static char *p;            /* Main character pointer for parsing.  */
 255 static char *lastpos;      /* Auxiliary pointer, for backing up.  */
 256 static int unit_num;       /* The last unit number read.  */
 257 static int unit_count;     /* The number of units found. */
 258 static int do_count;       /* Parsing is done twice - first to count the number
 259                               of units, then to fill in the table.  This
 260                               variable controls what to do.  */
 261 static exception_t *elist; /* The list of exceptions to the default. This is
 262                               sorted according to unit number.  */
 263 static int n_elist;        /* Number of exceptions to the default.  */
 264
 265 static unit_convert endian; /* Current endianness.  */
 266
 267 static unit_convert def; /* Default as specified (if any).  */
 268
 269 /* Search for a unit number, using a binary search.  The
 270    first argument is the unit number to search for.  The second argument
 271    is a pointer to an index.
 272    If the unit number is found, the function returns 1, and the index
 273    is that of the element.
 274    If the unit number is not found, the function returns 0, and the
 275    index is the one where the element would be inserted.  */
 276
 277 static int
 278 search_unit (int unit, int *ip)
 279 {
 280   int low, high, mid;
 281
 282   if (n_elist == 0)
 283     {
 284       *ip = 0;
 285       return 0;
 286     }
 287
 288   low = 0;
 289   high = n_elist - 1;
 290
 291   do
 292     {
 293       mid = (low + high) / 2;
 294       if (unit == elist[mid].unit)
 295         {
 296           *ip = mid;
 297           return 1;
 298         }
 299       else if (unit > elist[mid].unit)
 300         low = mid + 1;
 301       else
 302         high = mid - 1;
 303     } while (low <= high);
 304
 305   if (unit > elist[mid].unit)
 306     *ip = mid + 1;
 307   else
 308     *ip = mid;
 309
 310   return 0;
 311 }
 312
 313 /* This matches a keyword.  If it is found, return the token supplied,
 314    otherwise return ILLEGAL.  */
 315
 316 static int
 317 match_word (const char *word, int tok)
 318 {
 319   int res;
 320
 321   if (strncasecmp (p, word, strlen (word)) == 0)
 322     {
 323       p += strlen (word);
 324       res = tok;
 325     }
 326   else
 327     res = ILLEGAL;
 328   return res;
 329 }
 330
 331 /* Match an integer and store its value in unit_num.  This only works
 332    if p actually points to the start of an integer.  The caller has
 333    to ensure this.  */
 334
 335 static int
 336 match_integer (void)
 337 {
 338   unit_num = 0;
 339   while (isdigit (*p))
 340     unit_num = unit_num * 10 + (*p++ - '0');
 341   return INTEGER;
 342 }
 343
 344 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
 345    Returned values are the different tokens.  */
 346
 347 static int
 348 next_token (void)
 349 {
 350   int result;
 351
 352   lastpos = p;
 353   switch (*p)
 354     {
 355     case '\0':
 356       result = END;
 357       break;
 358
 359     case ':':
 360     case ',':
 361     case '-':
 362     case ';':
 363       result = *p;
 364       p++;
 365       break;
 366
 367     case 'b':
 368     case 'B':
 369       result = match_word ("big_endian", BIG);
 370       break;
 371
 372     case 'l':
 373     case 'L':
 374       result = match_word ("little_endian", LITTLE);
 375       break;
 376
 377     case 'n':
 378     case 'N':
 379       result = match_word ("native", NATIVE);
 380       break;
 381
 382     case 's':
 383     case 'S':
 384       result = match_word ("swap", SWAP);
 385       break;
 386
 387     case '1': case '2': case '3': case '4': case '5':
 388     case '6': case '7': case '8': case '9':
 389       result = match_integer ();
 390       break;
 391
 392     default:
 393       result = ILLEGAL;
 394       break;
 395     }
 396   return result;
 397 }
 398
 399 /* Back up the last token by setting back the character pointer.  */
 400
 401 static void
 402 push_token (void)
 403 {
 404   p = lastpos;
 405 }
 406
 407 /* This is called when a unit is identified.  If do_count is nonzero,
 408    increment the number of units by one.  If do_count is zero,
 409    put the unit into the table.  */
 410
 411 static void
 412 mark_single (int unit)
 413 {
 414   int i,j;
 415
 416   if (do_count)
 417     {
 418       unit_count++;
 419       return;
 420     }
 421   if (search_unit (unit, &i))
 422     {
 423       elist[i].conv = endian;
 424     }
 425   else
 426     {
 427       for (j=n_elist-1; j>=i; j--)
 428         elist[j+1] = elist[j];
 429
 430       n_elist += 1;
 431       elist[i].unit = unit;
 432       elist[i].conv = endian;
 433     }
 434 }
 435
 436 /* This is called when a unit range is identified.  If do_count is
 437    nonzero, increase the number of units.  If do_count is zero,
 438    put the unit into the table.  */
 439
 440 static void
 441 mark_range (int unit1, int unit2)
 442 {
 443   int i;
 444   if (do_count)
 445     unit_count += abs (unit2 - unit1) + 1;
 446   else
 447     {
 448       if (unit2 < unit1)
 449         for (i=unit2; i<=unit1; i++)
 450           mark_single (i);
 451       else
 452         for (i=unit1; i<=unit2; i++)
 453           mark_single (i);
 454     }
 455 }
 456
 457 /* Parse the GFORTRAN_CONVERT_UNITS variable.  This is called
 458    twice, once to count the units and once to actually mark them in
 459    the table.  When counting, we don't check for double occurrences
 460    of units.  */
 461
 462 static int
 463 do_parse (void)
 464 {
 465   int tok;
 466   int unit1;
 467   int continue_ulist;
 468   char *start;
 469
 470   unit_count = 0;
 471
 472   start = p;
 473
 474   /* Parse the string.  First, let's look for a default.  */
 475   tok = next_token ();
 476   switch (tok)
 477     {
 478     case NATIVE:
 479       endian = GFC_CONVERT_NATIVE;
 480       break;
 481
 482     case SWAP:
 483       endian = GFC_CONVERT_SWAP;
 484       break;
 485
 486     case BIG:
 487       endian = GFC_CONVERT_BIG;
 488       break;
 489
 490     case LITTLE:
 491       endian = GFC_CONVERT_LITTLE;
 492       break;
 493
 494     case INTEGER:
 495       /* A leading digit means that we are looking at an exception.
 496          Reset the position to the beginning, and continue processing
 497          at the exception list.  */
 498       p = start;
 499       goto exceptions;
 500       break;
 501
 502     case END:
 503       goto end;
 504       break;
 505
 506     default:
 507       goto error;
 508       break;
 509     }
 510
 511   tok = next_token ();
 512   switch (tok)
 513     {
 514     case ';':
 515       def = endian;
 516       break;
 517
 518     case ':':
 519       /* This isn't a default after all.  Reset the position to the
 520          beginning, and continue processing at the exception list.  */
 521       p = start;
 522       goto exceptions;
 523       break;
 524
 525     case END:
 526       def = endian;
 527       goto end;
 528       break;
 529
 530     default:
 531       goto error;
 532       break;
 533     }
 534
 535  exceptions:
 536
 537   /* Loop over all exceptions.  */
 538   while(1)
 539     {
 540       tok = next_token ();
 541       switch (tok)
 542         {
 543         case NATIVE:
 544           if (next_token () != ':')
 545             goto error;
 546           endian = GFC_CONVERT_NATIVE;
 547           break;
 548
 549         case SWAP:
 550           if (next_token () != ':')
 551             goto error;
 552           endian = GFC_CONVERT_SWAP;
 553           break;
 554
 555         case LITTLE:
 556           if (next_token () != ':')
 557             goto error;
 558           endian = GFC_CONVERT_LITTLE;
 559           break;
 560
 561         case BIG:
 562           if (next_token () != ':')
 563             goto error;
 564           endian = GFC_CONVERT_BIG;
 565           break;
 566
 567         case INTEGER:
 568           push_token ();
 569           break;
 570
 571         case END:
 572           goto end;
 573           break;
 574
 575         default:
 576           goto error;
 577           break;
 578         }
 579       /* We arrive here when we want to parse a list of
 580          numbers.  */
 581       continue_ulist = 1;
 582       do
 583         {
 584           tok = next_token ();
 585           if (tok != INTEGER)
 586             goto error;
 587
 588           unit1 = unit_num;
 589           tok = next_token ();
 590           /* The number can be followed by a - and another number,
 591              which means that this is a unit range, a comma
 592              or a semicolon.  */
 593           if (tok == '-')
 594             {
 595               if (next_token () != INTEGER)
 596                 goto error;
 597
 598               mark_range (unit1, unit_num);
 599               tok = next_token ();
 600               if (tok == END)
 601                 goto end;
 602               else if (tok == ';')
 603                 continue_ulist = 0;
 604               else if (tok != ',')
 605                 goto error;
 606             }
 607           else
 608             {
 609               mark_single (unit1);
 610               switch (tok)
 611                 {
 612                 case ';':
 613                   continue_ulist = 0;
 614                   break;
 615
 616                 case ',':
 617                   break;
 618
 619                 case END:
 620                   goto end;
 621                   break;
 622
 623                 default:
 624                   goto error;
 625                 }
 626             }
 627         } while (continue_ulist);
 628     }
 629  end:
 630   return 0;
 631  error:
 632   def = GFC_CONVERT_NONE;
 633   return -1;
 634 }
 635
 636 void init_unformatted (variable * v)
 637 {
 638   char *val;
 639   val = getenv (v->name);
 640   def = GFC_CONVERT_NONE;
 641   n_elist = 0;
 642
 643   if (val == NULL)
 644     return;
 645   do_count = 1;
 646   p = val;
 647   do_parse ();
 648   if (do_count <= 0)
 649     {
 650       n_elist = 0;
 651       elist = NULL;
 652     }
 653   else
 654     {
 655       elist = xmallocarray (unit_count, sizeof (exception_t));
 656       do_count = 0;
 657       p = val;
 658       do_parse ();
 659     }
 660 }
 661
 662 /* Get the default conversion for for an unformatted unit.  */
 663
 664 unit_convert
 665 get_unformatted_convert (int unit)
 666 {
 667   int i;
 668
 669   if (elist == NULL)
 670     return def;
 671   else if (search_unit (unit, &i))
 672     return elist[i].conv;
 673   else
 674     return def;
 675 }