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