libgfortran/runtime/environ.c

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