libgfortran/runtime/environ.c

   1 /* Copyright (C) 2002-2016 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 <stdlib.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 char *
  41 secure_getenv (const char *name)
  42 {
  43   if ((getuid () == geteuid ()) && (getgid () == getegid ()))
  44     return getenv (name);
  45   else
  46     return NULL;
  47 }
  48 #endif
  49
  50
  51
  52 /* Examine the environment for controlling aspects of the program's
  53    execution.  Our philosophy here that the environment should not prevent
  54    the program from running, so any invalid value will be ignored.  */
  55
  56
  57 options_t options;
  58
  59 typedef struct variable
  60 {
  61   const char *name;
  62   int default_value;
  63   int *var;
  64   void (*init) (struct variable *);
  65 }
  66 variable;
  67
  68 static void init_unformatted (variable *);
  69
  70
  71 /* Initialize an integer environment variable.  */
  72
  73 static void
  74 init_integer (variable * v)
  75 {
  76   char *p, *q;
  77
  78   p = getenv (v->name);
  79   if (p == NULL)
  80     return;
  81
  82   for (q = p; *q; q++)
  83     if (!isdigit (*q) && (p != q || *q != '-'))
  84       return;
  85
  86   *v->var = atoi (p);
  87 }
  88
  89
  90 /* Initialize an integer environment variable which has to be positive.  */
  91
  92 static void
  93 init_unsigned_integer (variable * v)
  94 {
  95   char *p, *q;
  96
  97   p = getenv (v->name);
  98   if (p == NULL)
  99     return;
 100
 101   for (q = p; *q; q++)
 102     if (!isdigit (*q))
 103       return;
 104
 105   *v->var = atoi (p);
 106 }
 107
 108
 109 /* Initialize a boolean environment variable. We only look at the first
 110    letter of the value. */
 111
 112 static void
 113 init_boolean (variable * v)
 114 {
 115   char *p;
 116
 117   p = getenv (v->name);
 118   if (p == NULL)
 119     return;
 120
 121   if (*p == '1' || *p == 'Y' || *p == 'y')
 122     *v->var = 1;
 123   else if (*p == '0' || *p == 'N' || *p == 'n')
 124     *v->var = 0;
 125 }
 126
 127
 128 /* Initialize a list output separator.  It may contain any number of spaces
 129    and at most one comma.  */
 130
 131 static void
 132 init_sep (variable * v)
 133 {
 134   int seen_comma;
 135   char *p;
 136
 137   p = getenv (v->name);
 138   if (p == NULL)
 139     goto set_default;
 140
 141   options.separator = p;
 142   options.separator_len = strlen (p);
 143
 144   /* Make sure the separator is valid */
 145
 146   if (options.separator_len == 0)
 147     goto set_default;
 148   seen_comma = 0;
 149
 150   while (*p)
 151     {
 152       if (*p == ',')
 153         {
 154           if (seen_comma)
 155             goto set_default;
 156           seen_comma = 1;
 157           p++;
 158           continue;
 159         }
 160
 161       if (*p++ != ' ')
 162         goto set_default;
 163     }
 164
 165   return;
 166
 167 set_default:
 168   options.separator = " ";
 169   options.separator_len = 1;
 170 }
 171
 172
 173 static variable variable_table[] = {
 174
 175   /* Unit number that will be preconnected to standard input */
 176   { "GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
 177     init_integer },
 178
 179   /* Unit number that will be preconnected to standard output */
 180   { "GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
 181     init_integer },
 182
 183   /* Unit number that will be preconnected to standard error */
 184   { "GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
 185     init_integer },
 186
 187   /* If TRUE, all output will be unbuffered */
 188   { "GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean },
 189
 190   /* If TRUE, output to preconnected units will be unbuffered */
 191   { "GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
 192     init_boolean },
 193
 194   /* Whether to print filename and line number on runtime error */
 195   { "GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean },
 196
 197   /* Print optional plus signs in numbers where permitted */
 198   { "GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean },
 199
 200   /* Default maximum record length for sequential files */
 201   { "GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
 202     init_unsigned_integer },
 203
 204   /* Separator to use when writing list output */
 205   { "GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep },
 206
 207   /* Set the default data conversion for unformatted I/O */
 208   { "GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted },
 209
 210   /* Print out a backtrace if possible on runtime error */
 211   { "GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace, init_boolean },
 212
 213   { NULL, 0, NULL, NULL }
 214 };
 215
 216
 217 /* Initialize most runtime variables from
 218  * environment variables. */
 219
 220 void
 221 init_variables (void)
 222 {
 223   variable *v;
 224
 225   for (v = variable_table; v->name; v++)
 226     {
 227       if (v->var)
 228         *v->var = v->default_value;
 229       v->init (v);
 230     }
 231 }
 232
 233
 234 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
 235    It is called from environ.c to parse this variable, and from
 236    open.c to determine if the user specified a default for an
 237    unformatted file.
 238    The syntax of the environment variable is, in bison grammar:
 239
 240    GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
 241    mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
 242    exception: mode ':' unit_list | unit_list ;
 243    unit_list: unit_spec | unit_list unit_spec ;
 244    unit_spec: INTEGER | INTEGER '-' INTEGER ;
 245 */
 246
 247 /* Defines for the tokens.  Other valid tokens are ',', ':', '-'.  */
 248
 249
 250 #define NATIVE   257
 251 #define SWAP     258
 252 #define BIG      259
 253 #define LITTLE   260
 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 (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     case '1': case '2': case '3': case '4': case '5':
 400     case '6': case '7': case '8': case '9':
 401       result = match_integer ();
 402       break;
 403
 404     default:
 405       result = ILLEGAL;
 406       break;
 407     }
 408   return result;
 409 }
 410
 411 /* Back up the last token by setting back the character pointer.  */
 412
 413 static void
 414 push_token (void)
 415 {
 416   p = lastpos;
 417 }
 418
 419 /* This is called when a unit is identified.  If do_count is nonzero,
 420    increment the number of units by one.  If do_count is zero,
 421    put the unit into the table.  */
 422
 423 static void
 424 mark_single (int unit)
 425 {
 426   int i,j;
 427
 428   if (do_count)
 429     {
 430       unit_count++;
 431       return;
 432     }
 433   if (search_unit (unit, &i))
 434     {
 435       elist[i].conv = endian;
 436     }
 437   else
 438     {
 439       for (j=n_elist-1; j>=i; j--)
 440         elist[j+1] = elist[j];
 441
 442       n_elist += 1;
 443       elist[i].unit = unit;
 444       elist[i].conv = endian;
 445     }
 446 }
 447
 448 /* This is called when a unit range is identified.  If do_count is
 449    nonzero, increase the number of units.  If do_count is zero,
 450    put the unit into the table.  */
 451
 452 static void
 453 mark_range (int unit1, int unit2)
 454 {
 455   int i;
 456   if (do_count)
 457     unit_count += abs (unit2 - unit1) + 1;
 458   else
 459     {
 460       if (unit2 < unit1)
 461         for (i=unit2; i<=unit1; i++)
 462           mark_single (i);
 463       else
 464         for (i=unit1; i<=unit2; i++)
 465           mark_single (i);
 466     }
 467 }
 468
 469 /* Parse the GFORTRAN_CONVERT_UNITS variable.  This is called
 470    twice, once to count the units and once to actually mark them in
 471    the table.  When counting, we don't check for double occurrences
 472    of units.  */
 473
 474 static int
 475 do_parse (void)
 476 {
 477   int tok;
 478   int unit1;
 479   int continue_ulist;
 480   char *start;
 481
 482   unit_count = 0;
 483
 484   start = p;
 485
 486   /* Parse the string.  First, let's look for a default.  */
 487   tok = next_token ();
 488   switch (tok)
 489     {
 490     case NATIVE:
 491       endian = GFC_CONVERT_NATIVE;
 492       break;
 493
 494     case SWAP:
 495       endian = GFC_CONVERT_SWAP;
 496       break;
 497
 498     case BIG:
 499       endian = GFC_CONVERT_BIG;
 500       break;
 501
 502     case LITTLE:
 503       endian = GFC_CONVERT_LITTLE;
 504       break;
 505
 506     case INTEGER:
 507       /* A leading digit means that we are looking at an exception.
 508          Reset the position to the beginning, and continue processing
 509          at the exception list.  */
 510       p = start;
 511       goto exceptions;
 512       break;
 513
 514     case END:
 515       goto end;
 516       break;
 517
 518     default:
 519       goto error;
 520       break;
 521     }
 522
 523   tok = next_token ();
 524   switch (tok)
 525     {
 526     case ';':
 527       def = endian;
 528       break;
 529
 530     case ':':
 531       /* This isn't a default after all.  Reset the position to the
 532          beginning, and continue processing at the exception list.  */
 533       p = start;
 534       goto exceptions;
 535       break;
 536
 537     case END:
 538       def = endian;
 539       goto end;
 540       break;
 541
 542     default:
 543       goto error;
 544       break;
 545     }
 546
 547  exceptions:
 548
 549   /* Loop over all exceptions.  */
 550   while(1)
 551     {
 552       tok = next_token ();
 553       switch (tok)
 554         {
 555         case NATIVE:
 556           if (next_token () != ':')
 557             goto error;
 558           endian = GFC_CONVERT_NATIVE;
 559           break;
 560
 561         case SWAP:
 562           if (next_token () != ':')
 563             goto error;
 564           endian = GFC_CONVERT_SWAP;
 565           break;
 566
 567         case LITTLE:
 568           if (next_token () != ':')
 569             goto error;
 570           endian = GFC_CONVERT_LITTLE;
 571           break;
 572
 573         case BIG:
 574           if (next_token () != ':')
 575             goto error;
 576           endian = GFC_CONVERT_BIG;
 577           break;
 578
 579         case INTEGER:
 580           push_token ();
 581           break;
 582
 583         case END:
 584           goto end;
 585           break;
 586
 587         default:
 588           goto error;
 589           break;
 590         }
 591       /* We arrive here when we want to parse a list of
 592          numbers.  */
 593       continue_ulist = 1;
 594       do
 595         {
 596           tok = next_token ();
 597           if (tok != INTEGER)
 598             goto error;
 599
 600           unit1 = unit_num;
 601           tok = next_token ();
 602           /* The number can be followed by a - and another number,
 603              which means that this is a unit range, a comma
 604              or a semicolon.  */
 605           if (tok == '-')
 606             {
 607               if (next_token () != INTEGER)
 608                 goto error;
 609
 610               mark_range (unit1, unit_num);
 611               tok = next_token ();
 612               if (tok == END)
 613                 goto end;
 614               else if (tok == ';')
 615                 continue_ulist = 0;
 616               else if (tok != ',')
 617                 goto error;
 618             }
 619           else
 620             {
 621               mark_single (unit1);
 622               switch (tok)
 623                 {
 624                 case ';':
 625                   continue_ulist = 0;
 626                   break;
 627
 628                 case ',':
 629                   break;
 630
 631                 case END:
 632                   goto end;
 633                   break;
 634
 635                 default:
 636                   goto error;
 637                 }
 638             }
 639         } while (continue_ulist);
 640     }
 641  end:
 642   return 0;
 643  error:
 644   def = GFC_CONVERT_NONE;
 645   return -1;
 646 }
 647
 648 void init_unformatted (variable * v)
 649 {
 650   char *val;
 651   val = getenv (v->name);
 652   def = GFC_CONVERT_NONE;
 653   n_elist = 0;
 654
 655   if (val == NULL)
 656     return;
 657   do_count = 1;
 658   p = val;
 659   do_parse ();
 660   if (do_count <= 0)
 661     {
 662       n_elist = 0;
 663       elist = NULL;
 664     }
 665   else
 666     {
 667       elist = xmallocarray (unit_count, sizeof (exception_t));
 668       do_count = 0;
 669       p = val;
 670       do_parse ();
 671     }
 672 }
 673
 674 /* Get the default conversion for for an unformatted unit.  */
 675
 676 unit_convert
 677 get_unformatted_convert (int unit)
 678 {
 679   int i;
 680
 681   if (elist == NULL)
 682     return def;
 683   else if (search_unit (unit, &i))
 684     return elist[i].conv;
 685   else
 686     return def;
 687 }