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   if (n_elist == 0)
 463     {
 464       *ip = 0;
 465       return 0;
 466     }
 467
 468   low = 0;
 469   high = n_elist - 1;
 470
 471   do
 472     {
 473       mid = (low + high) / 2;
 474       if (unit == elist[mid].unit)
 475         {
 476           *ip = mid;
 477           return 1;
 478         }
 479       else if (unit > elist[mid].unit)
 480         low = mid + 1;
 481       else
 482         high = mid - 1;
 483     } while (low <= high);
 484
 485   if (unit > elist[mid].unit)
 486     *ip = mid + 1;
 487   else
 488     *ip = mid;
 489
 490   return 0;
 491 }
 492
 493 /* This matches a keyword.  If it is found, return the token supplied,
 494    otherwise return ILLEGAL.  */
 495
 496 static int
 497 match_word (const char *word, int tok)
 498 {
 499   int res;
 500
 501   if (strncasecmp (p, word, strlen (word)) == 0)
 502     {
 503       p += strlen (word);
 504       res = tok;
 505     }
 506   else
 507     res = ILLEGAL;
 508   return res;
 509
 510 }
 511
 512 /* Match an integer and store its value in unit_num.  This only works
 513    if p actually points to the start of an integer.  The caller has
 514    to ensure this.  */
 515
 516 static int
 517 match_integer (void)
 518 {
 519   unit_num = 0;
 520   while (isdigit (*p))
 521     unit_num = unit_num * 10 + (*p++ - '0');
 522   return INTEGER;
 523
 524 }
 525
 526 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
 527    Returned values are the different tokens.  */
 528
 529 static int
 530 next_token (void)
 531 {
 532   int result;
 533
 534   lastpos = p;
 535   switch (*p)
 536     {
 537     case '\0':
 538       result = END;
 539       break;
 540
 541     case ':':
 542     case ',':
 543     case '-':
 544     case ';':
 545       result = *p;
 546       p++;
 547       break;
 548
 549     case 'b':
 550     case 'B':
 551       result = match_word ("big_endian", BIG);
 552       break;
 553
 554     case 'l':
 555     case 'L':
 556       result = match_word ("little_endian", LITTLE);
 557       break;
 558
 559     case 'n':
 560     case 'N':
 561       result = match_word ("native", NATIVE);
 562       break;
 563
 564     case 's':
 565     case 'S':
 566       result = match_word ("swap", SWAP);
 567       break;
 568
 569     case '1': case '2': case '3': case '4': case '5':
 570     case '6': case '7': case '8': case '9':
 571       result = match_integer ();
 572       break;
 573
 574     default:
 575       result = ILLEGAL;
 576       break;
 577     }
 578   return result;
 579 }
 580
 581 /* Back up the last token by setting back the character pointer.  */
 582
 583 static void
 584 push_token (void)
 585 {
 586   p = lastpos;
 587 }
 588
 589 /* This is called when a unit is identified.  If do_count is nonzero,
 590    increment the number of units by one.  If do_count is zero,
 591    put the unit into the table.  */
 592
 593 static void
 594 mark_single (int unit)
 595 {
 596   int i,j;
 597
 598   if (do_count)
 599     {
 600       unit_count++;
 601       return;
 602     }
 603   if (search_unit (unit, &i))
 604     {
 605       elist[i].conv = endian;
 606     }
 607   else
 608     {
 609       for (j=n_elist-1; j>=i; j--)
 610         elist[j+1] = elist[j];
 611
 612       n_elist += 1;
 613       elist[i].unit = unit;
 614       elist[i].conv = endian;
 615     }
 616 }
 617
 618 /* This is called when a unit range is identified.  If do_count is
 619    nonzero, increase the number of units.  If do_count is zero,
 620    put the unit into the table.  */
 621
 622 static void
 623 mark_range (int unit1, int unit2)
 624 {
 625   int i;
 626   if (do_count)
 627     unit_count += abs (unit2 - unit1) + 1;
 628   else
 629     {
 630       if (unit2 < unit1)
 631         for (i=unit2; i<=unit1; i++)
 632           mark_single (i);
 633       else
 634         for (i=unit1; i<=unit2; i++)
 635           mark_single (i);
 636     }
 637 }
 638
 639 /* Parse the GFORTRAN_CONVERT_UNITS variable.  This is called
 640    twice, once to count the units and once to actually mark them in
 641    the table.  When counting, we don't check for double occurrences
 642    of units.  */
 643
 644 static int
 645 do_parse (void)
 646 {
 647   int tok;
 648   int unit1;
 649   int continue_ulist;
 650   char *start;
 651
 652   unit_count = 0;
 653
 654   start = p;
 655
 656   /* Parse the string.  First, let's look for a default.  */
 657   tok = next_token ();
 658   switch (tok)
 659     {
 660     case NATIVE:
 661       endian = GFC_CONVERT_NATIVE;
 662       break;
 663
 664     case SWAP:
 665       endian = GFC_CONVERT_SWAP;
 666       break;
 667
 668     case BIG:
 669       endian = GFC_CONVERT_BIG;
 670       break;
 671
 672     case LITTLE:
 673       endian = GFC_CONVERT_LITTLE;
 674       break;
 675
 676     case INTEGER:
 677       /* A leading digit means that we are looking at an exception.
 678          Reset the position to the beginning, and continue processing
 679          at the exception list.  */
 680       p = start;
 681       goto exceptions;
 682       break;
 683
 684     case END:
 685       goto end;
 686       break;
 687
 688     default:
 689       goto error;
 690       break;
 691     }
 692
 693   tok = next_token ();
 694   switch (tok)
 695     {
 696     case ';':
 697       def = endian;
 698       break;
 699
 700     case ':':
 701       /* This isn't a default after all.  Reset the position to the
 702          beginning, and continue processing at the exception list.  */
 703       p = start;
 704       goto exceptions;
 705       break;
 706
 707     case END:
 708       def = endian;
 709       goto end;
 710       break;
 711
 712     default:
 713       goto error;
 714       break;
 715     }
 716
 717  exceptions:
 718
 719   /* Loop over all exceptions.  */
 720   while(1)
 721     {
 722       tok = next_token ();
 723       switch (tok)
 724         {
 725         case NATIVE:
 726           if (next_token () != ':')
 727             goto error;
 728           endian = GFC_CONVERT_NATIVE;
 729           break;
 730
 731         case SWAP:
 732           if (next_token () != ':')
 733             goto error;
 734           endian = GFC_CONVERT_SWAP;
 735           break;
 736
 737         case LITTLE:
 738           if (next_token () != ':')
 739             goto error;
 740           endian = GFC_CONVERT_LITTLE;
 741           break;
 742
 743         case BIG:
 744           if (next_token () != ':')
 745             goto error;
 746           endian = GFC_CONVERT_BIG;
 747           break;
 748
 749         case INTEGER:
 750           push_token ();
 751           break;
 752
 753         case END:
 754           goto end;
 755           break;
 756
 757         default:
 758           goto error;
 759           break;
 760         }
 761       /* We arrive here when we want to parse a list of
 762          numbers.  */
 763       continue_ulist = 1;
 764       do
 765         {
 766           tok = next_token ();
 767           if (tok != INTEGER)
 768             goto error;
 769
 770           unit1 = unit_num;
 771           tok = next_token ();
 772           /* The number can be followed by a - and another number,
 773              which means that this is a unit range, a comma
 774              or a semicolon.  */
 775           if (tok == '-')
 776             {
 777               if (next_token () != INTEGER)
 778                 goto error;
 779
 780               mark_range (unit1, unit_num);
 781               tok = next_token ();
 782               if (tok == END)
 783                 goto end;
 784               else if (tok == ';')
 785                 continue_ulist = 0;
 786               else if (tok != ',')
 787                 goto error;
 788             }
 789           else
 790             {
 791               mark_single (unit1);
 792               switch (tok)
 793                 {
 794                 case ';':
 795                   continue_ulist = 0;
 796                   break;
 797
 798                 case ',':
 799                   break;
 800
 801                 case END:
 802                   goto end;
 803                   break;
 804
 805                 default:
 806                   goto error;
 807                 }
 808             }
 809         } while (continue_ulist);
 810     }
 811  end:
 812   return 0;
 813  error:
 814   def = GFC_CONVERT_NONE;
 815   return -1;
 816 }
 817
 818 void init_unformatted (variable * v)
 819 {
 820   char *val;
 821   val = getenv (v->name);
 822   def = GFC_CONVERT_NONE;
 823   n_elist = 0;
 824
 825   if (val == NULL)
 826     return;
 827   do_count = 1;
 828   p = val;
 829   do_parse ();
 830   if (do_count <= 0)
 831     {
 832       n_elist = 0;
 833       elist = NULL;
 834     }
 835   else
 836     {
 837       elist = xmalloc (unit_count * sizeof (exception_t));
 838       do_count = 0;
 839       p = val;
 840       do_parse ();
 841     }
 842 }
 843
 844 /* Get the default conversion for for an unformatted unit.  */
 845
 846 unit_convert
 847 get_unformatted_convert (int unit)
 848 {
 849   int i;
 850
 851   if (elist == NULL)
 852     return def;
 853   else if (search_unit (unit, &i))
 854     return elist[i].conv;
 855   else
 856     return def;
 857 }