libgfortran/runtime/environ.c

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