libgfortran/runtime/environ.c

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