lily/general-scheme.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 1998--2015 Jan Nieuwenhuizen <janneke@gnu.org>
   5   Han-Wen Nienhuys <hanwen@xs4all.nl>
   6
   7   LilyPond 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 of the License, or
  10   (at your option) any later version.
  11
  12   LilyPond 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   You should have received a copy of the GNU General Public License
  18   along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  19 */
  20
  21 #include "config.hh"
  22
  23 #include <cstdio>
  24 #include <ctype.h>
  25 #include <cstring>  /* memset */
  26 #include <glib.h>
  27
  28 #include "dimensions.hh"
  29 #include "file-name.hh"
  30 #include "file-path.hh"
  31 #include "international.hh"
  32 #include "libc-extension.hh"
  33 #include "lily-guile.hh"
  34 #include "main.hh"
  35 #include "misc.hh"
  36 #include "program-option.hh"
  37 #include "relocate.hh"
  38 #include "string-convert.hh"
  39 #include "version.hh"
  40 #include "warn.hh"
  41
  42 using std::string;
  43 using std::vector;
  44
  45 /* Declaration of log function(s) */
  46 SCM ly_progress (SCM, SCM);
  47
  48 LY_DEFINE (ly_start_environment, "ly:start-environment",
  49            0, 0, 0, (),
  50            "Return the environment (a list of strings) that was in"
  51            " effect at program start.")
  52 {
  53   SCM l = SCM_EOL;
  54   SCM *tail = &l;
  55
  56   for (vsize i = 0; i < start_environment_global.size (); i++)
  57     {
  58       *tail = scm_cons (ly_string2scm (start_environment_global[i]),
  59                         SCM_EOL);
  60       tail = SCM_CDRLOC (*tail);
  61     }
  62
  63   return l;
  64 }
  65
  66 LY_DEFINE (ly_find_file, "ly:find-file",
  67            1, 0, 0, (SCM name),
  68            "Return the absolute file name of @var{name},"
  69            " or @code{#f} if not found.")
  70 {
  71   LY_ASSERT_TYPE (scm_is_string, name, 1);
  72
  73   string nm = ly_scm2string (name);
  74   string file_name = global_path.find (nm);
  75   if (file_name.empty ())
  76     return SCM_BOOL_F;
  77
  78   return ly_string2scm (file_name);
  79 }
  80
  81 /*
  82   Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
  83   buffering.)
  84 */
  85 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
  86            1, 1, 0, (SCM name, SCM size),
  87            "Read @var{size} characters from the file @var{name},"
  88            " and return its contents in a string."
  89            "  If @var{size} is undefined, the entire file is read."
  90            "  The file is looked up using the search path.")
  91 {
  92   LY_ASSERT_TYPE (scm_is_string, name, 1);
  93   int sz = INT_MAX;
  94   if (!SCM_UNBNDP (size))
  95     {
  96       LY_ASSERT_TYPE (scm_is_number, size, 2);
  97       sz = scm_to_int (size);
  98     }
  99
 100   string contents = gulp_file_to_string (ly_scm2string (name), true, sz);
 101   return scm_from_latin1_stringn (contents.c_str (), contents.length ());
 102 }
 103
 104 LY_DEFINE (ly_dir_p, "ly:dir?",
 105            1, 0, 0, (SCM s),
 106            "Is @var{s} a direction?  Valid directions are @w{@code{-1}},"
 107            " @code{0}, or@tie{}@code{1}, where @w{@code{-1}} represents"
 108            " left or down, @code{1}@tie{}represents right or up, and @code{0}"
 109            " represents a neutral direction.")
 110 {
 111   if (scm_is_integer (s))
 112     {
 113       int i = scm_to_int (s);
 114       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
 115     }
 116   return SCM_BOOL_F;
 117 }
 118
 119 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
 120            2, 2, 0,
 121            (SCM key, SCM alist, SCM default_value, SCM strict_checking),
 122            "Return value if @var{key} in @var{alist}, else @var{default-value}"
 123            " (or @code{#f} if not specified).  If @var{strict-checking} is set"
 124            " to @code{#t} and @var{key} is not in @var{alist}, a programming_error"
 125            " is output.")
 126 {
 127   LY_ASSERT_TYPE (ly_cheap_is_list, alist, 2);
 128
 129   SCM handle = scm_assoc (key, alist);
 130   if (scm_is_pair (handle))
 131     return scm_cdr (handle);
 132
 133   if (SCM_UNBNDP (default_value))
 134     default_value = SCM_BOOL_F;
 135
 136   if (to_boolean (strict_checking))
 137     {
 138       string key_string = ly_scm2string
 139                           (scm_object_to_string (key, SCM_UNDEFINED));
 140       string default_value_string = ly_scm2string
 141                                     (scm_object_to_string (default_value,
 142                                                            SCM_UNDEFINED));
 143       programming_error ("Cannot find key `"
 144                          + key_string
 145                          + "' in alist, setting to `"
 146                          + default_value_string + "'.");
 147     }
 148
 149   return default_value;
 150 }
 151
 152 LY_DEFINE (ly_string_substitute, "ly:string-substitute",
 153            3, 0, 0, (SCM a, SCM b, SCM s),
 154            "Replace string@tie{}@var{a} by string@tie{}@var{b} in"
 155            " string@tie{}@var{s}.")
 156 {
 157   LY_ASSERT_TYPE (scm_is_string, s, 1);
 158   LY_ASSERT_TYPE (scm_is_string, b, 2);
 159   LY_ASSERT_TYPE (scm_is_string, s, 3);
 160
 161   string ss = ly_scm2string (s);
 162   replace_all (&ss, ly_scm2string (a),
 163                ly_scm2string (b));
 164
 165   return ly_string2scm (ss);
 166 }
 167
 168 bool
 169 is_not_escape_character (Byte c)
 170 {
 171   switch (c)
 172     {
 173     case '-':
 174     case '.':
 175     case '/':
 176     case '0'...'9':
 177     case ':':
 178     case 'A'...'Z':
 179     case '_':
 180     case 'a'...'z':
 181       return true;
 182     }
 183
 184   return false;
 185 }
 186
 187 LY_DEFINE (ly_string_percent_encode, "ly:string-percent-encode",
 188            1, 0, 0, (SCM str),
 189            "Encode all characters in string @var{str} with hexadecimal"
 190            " percent escape sequences, with the following exceptions:"
 191            " characters @w{@code{-},} @code{.}, @code{/}, and @code{_}; and"
 192            " characters in ranges @code{0-9}, @code{A-Z}, and @code{a-z}.")
 193 {
 194   LY_ASSERT_TYPE (scm_is_string, str, 1);
 195
 196   string orig_str = ly_scm2string (str);
 197   string new_str = "";
 198
 199   vsize i = 0;
 200   vsize n = orig_str.size ();
 201
 202   while (i < n)
 203     {
 204       Byte cur = orig_str[i];
 205
 206       if (is_not_escape_character (cur))
 207         new_str += cur;
 208       else
 209         {
 210           new_str += '%';
 211           new_str += String_convert::bin2hex (cur);
 212         }
 213
 214       i++;
 215     }
 216
 217   return ly_string2scm (new_str);
 218 }
 219
 220 LY_DEFINE (ly_number_2_string, "ly:number->string",
 221            1, 0, 0, (SCM s),
 222            "Convert @var{s} to a string without generating many decimals.")
 223 {
 224   LY_ASSERT_TYPE (scm_is_number, s, 1);
 225
 226   char str[400];                        // ugh.
 227
 228   if (scm_is_false (scm_exact_p (s)))
 229     {
 230       Real r (scm_to_double (s));
 231       if (isinf (r) || isnan (r))
 232         {
 233           programming_error ("infinity or NaN encountered while converting Real number, "
 234                              "setting to zero");
 235
 236           r = 0.0;
 237         }
 238
 239       snprintf (str, sizeof (str), "%.4f", r);
 240     }
 241   else
 242     snprintf (str, sizeof (str), "%d", int (scm_to_int (s)));
 243
 244   return scm_from_ascii_string (str);
 245 }
 246
 247 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
 248            "Return the current lilypond version as a list, e.g.,"
 249            " @code{(1 3 127 uu1)}.")
 250 {
 251   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
 252
 253   return scm_c_eval_string ((char *)vs);
 254 }
 255
 256 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
 257            "Return the unit used for lengths as a string.")
 258 {
 259   return scm_from_ascii_string (INTERNAL_UNIT);
 260 }
 261
 262 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
 263            "Return @var{d} as a number.  Used to distinguish length"
 264            " variables from normal numbers.")
 265 {
 266   return scm_number_p (d);
 267 }
 268
 269 /*
 270   Debugging mem leaks:
 271 */
 272 LY_DEFINE (ly_protects, "ly:protects",
 273            0, 0, 0, (),
 274            "Return hash of protected objects.")
 275 {
 276   //scm_protects is available only in Guile versions before 2.1.
 277 #if SCM_MAJOR_VERSION < 2 || SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION < 1
 278   return scm_protects;
 279 #else
 280   return programming_error ("ly:protects is not supported in Guile 2.1");
 281 #endif
 282 }
 283
 284 LY_DEFINE (ly_gettext, "ly:gettext",
 285            1, 0, 0, (SCM original),
 286            "A Scheme wrapper function for @code{gettext}.")
 287 {
 288   LY_ASSERT_TYPE (scm_is_string, original, 1);
 289   return ly_string2scm (_ (ly_scm2string (original).c_str ()));
 290 }
 291
 292 LY_DEFINE (ly_output_formats, "ly:output-formats",
 293            0, 0, 0, (),
 294            "Formats passed to @option{--format} as a list of strings,"
 295            " used for the output.")
 296 {
 297   vector<string> output_formats = string_split (output_format_global, ',');
 298
 299   SCM lst = SCM_EOL;
 300   int output_formats_count = output_formats.size ();
 301   for (int i = 0; i < output_formats_count; i++)
 302     lst = scm_cons (ly_string2scm (output_formats[i]), lst);
 303
 304   return lst;
 305 }
 306
 307 LY_DEFINE (ly_bigpdfs, "ly:bigpdfs",
 308            0, 0, 0, (),
 309            "Return true if the command line includes the @option{--bigpdf} parameter."
 310 )
 311 {
 312   return bigpdfs ? SCM_BOOL_T : SCM_BOOL_F;
 313 }
 314
 315 LY_DEFINE (ly_wide_char_2_utf_8, "ly:wide-char->utf-8",
 316            1, 0, 0, (SCM wc),
 317            "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8.")
 318 {
 319   char buf[5];
 320
 321   LY_ASSERT_TYPE (scm_is_integer, wc, 1);
 322   unsigned wide_char = (unsigned) scm_to_int (wc);
 323   char *p = buf;
 324
 325   if (wide_char < 0x0080)
 326     *p++ = (char)wide_char;
 327   else if (wide_char < 0x0800)
 328     {
 329       *p++ = (char) (((wide_char >> 6)) | 0xC0);
 330       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 331     }
 332   else if (wide_char < 0x10000)
 333     {
 334       *p++ = (char) (((wide_char >> 12)) | 0xE0);
 335       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 336       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 337     }
 338   else
 339     {
 340       *p++ = (char) (((wide_char >> 18)) | 0xF0);
 341       *p++ = (char) (((wide_char >> 12) & 0x3F) | 0x80);
 342       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 343       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 344     }
 345   *p = 0;
 346
 347   return scm_from_utf8_string (buf);
 348 }
 349
 350 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 351            0, 0, 0, (),
 352            "Return effective prefix.")
 353 {
 354   return ly_string2scm (lilypond_datadir);
 355 }
 356
 357 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
 358            2, 2, 0, (SCM key, SCM achain, SCM default_value, SCM strict_checking),
 359            "Return value for @var{key} from a list of alists @var{achain}."
 360            "  If no entry is found, return @var{default-value} or @code{#f} if"
 361            " @var{default-value} is not specified.  With @var{strict-checking}"
 362            " set to @code{#t}, a programming_error is output in such cases.")
 363 {
 364   if (scm_is_pair (achain))
 365     {
 366       SCM handle = scm_assoc (key, scm_car (achain));
 367       if (scm_is_pair (handle))
 368         return scm_cdr (handle);
 369       else
 370         return ly_chain_assoc_get (key, scm_cdr (achain), default_value);
 371     }
 372
 373   if (to_boolean (strict_checking))
 374     {
 375       string key_string = ly_scm2string
 376                           (scm_object_to_string (key, SCM_UNDEFINED));
 377       string default_value_string = ly_scm2string
 378                                     (scm_object_to_string (default_value,
 379                                                            SCM_UNDEFINED));
 380       programming_error ("Cannot find key `"
 381                          + key_string
 382                          + "' in achain, setting to `"
 383                          + default_value_string + "'.");
 384     }
 385
 386   return SCM_UNBNDP (default_value) ? SCM_BOOL_F : default_value;
 387 }
 388
 389 LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
 390            1, 1, 0, (SCM file_name, SCM mode),
 391            "Redirect stderr to @var{file-name}, opened with @var{mode}.")
 392 {
 393   LY_ASSERT_TYPE (scm_is_string, file_name, 1);
 394
 395   string m = "w";
 396   string f = ly_scm2string (file_name);
 397   FILE *stderrfile;
 398   if (scm_is_string (mode))
 399     m = ly_scm2string (mode);
 400   /* dup2 and (fileno (current-error-port)) do not work with mingw'c
 401      gcc -mwindows.  */
 402   fflush (stderr);
 403   stderrfile = freopen (f.c_str (), m.c_str (), stderr);
 404   if (!stderrfile)
 405     error (_f ("failed redirecting stderr to `%s'", f.c_str ()));
 406   return SCM_UNSPECIFIED;
 407 }
 408
 409 static SCM
 410 accumulate_symbol (void * /* closure */,
 411                    SCM key,
 412                    SCM /* val */,
 413                    SCM result)
 414 {
 415   return scm_cons (key, result);
 416 }
 417
 418 LY_DEFINE (ly_hash_table_keys, "ly:hash-table-keys",
 419            1, 0, 0, (SCM tab),
 420            "Return a list of keys in @var{tab}.")
 421 {
 422   return scm_internal_hash_fold ((scm_t_hash_fold_fn) &accumulate_symbol,
 423                                  NULL, SCM_EOL, tab);
 424 }
 425
 426 LY_DEFINE (ly_camel_case_2_lisp_identifier, "ly:camel-case->lisp-identifier",
 427            1, 0, 0, (SCM name_sym),
 428            "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
 429 {
 430   LY_ASSERT_TYPE (ly_is_symbol, name_sym, 1);
 431
 432   /*
 433     TODO: should use strings instead?
 434   */
 435
 436   const string in = ly_symbol2string (name_sym);
 437   string result = camel_case_to_lisp_identifier (in);
 438
 439   return ly_symbol2scm (result.c_str ());
 440 }
 441
 442 LY_DEFINE (ly_expand_environment, "ly:expand-environment",
 443            1, 0, 0, (SCM str),
 444            "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
 445 {
 446   LY_ASSERT_TYPE (scm_is_string, str, 1);
 447
 448   return ly_string2scm (expand_environment_variables (ly_scm2string (str)));
 449 }
 450
 451 LY_DEFINE (ly_truncate_list_x, "ly:truncate-list!",
 452            2, 0, 0, (SCM lst, SCM i),
 453            "Take at most the first @var{i} of list @var{lst}.")
 454 {
 455   LY_ASSERT_TYPE (scm_is_integer, i, 1);
 456
 457   int k = scm_to_int (i);
 458   if (k == 0)
 459     lst = SCM_EOL;
 460   else
 461     {
 462       SCM s = lst;
 463       k--;
 464       for (; scm_is_pair (s) && k--; s = scm_cdr (s))
 465         ;
 466
 467       if (scm_is_pair (s))
 468         scm_set_cdr_x (s, SCM_EOL);
 469     }
 470   return lst;
 471 }
 472
 473 string
 474 format_single_argument (SCM arg, int precision, bool escape = false)
 475 {
 476   if (scm_is_integer (arg) && scm_is_true (scm_exact_p (arg)))
 477     return (String_convert::int_string (scm_to_int (arg)));
 478   else if (scm_is_number (arg))
 479     {
 480       Real val = scm_to_double (arg);
 481
 482       if (isnan (val) || isinf (val))
 483         {
 484           warning (_ ("Found infinity or nan in output.  Substituting 0.0"));
 485           return ("0.0");
 486           if (strict_infinity_checking)
 487             abort ();
 488         }
 489       else
 490         return (String_convert::form_string ("%.*lf", precision, val));
 491     }
 492   else if (scm_is_string (arg))
 493     {
 494       string s = ly_scm2string (arg);
 495       if (escape)
 496         {
 497           // Escape backslashes and double quotes, wrap it in double quotes
 498           replace_all (&s, "\\", "\\\\");
 499           replace_all (&s, "\"", "\\\"");
 500           // don't replace percents, since the png backend uses %d as escape sequence
 501           // replace_all (&s, "%", "\\%");
 502           replace_all (&s, "$", "\\$");
 503           s = "\"" + s + "\"";
 504         }
 505       return s;
 506     }
 507   else if (scm_is_symbol (arg))
 508     return (ly_symbol2string (arg));
 509   else
 510     {
 511       ly_progress (scm_from_ascii_string ("\nUnsupported SCM value for format: ~a"),
 512                    scm_list_1 (arg));
 513     }
 514
 515   return "";
 516 }
 517
 518 LY_DEFINE (ly_format, "ly:format",
 519            1, 0, 1, (SCM str, SCM rest),
 520            "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}."
 521            "  Basic support for @code{~s} is also provided.")
 522 {
 523   LY_ASSERT_TYPE (scm_is_string, str, 1);
 524
 525   string format = ly_scm2string (str);
 526   vector<string> results;
 527
 528   vsize i = 0;
 529   while (i < format.size ())
 530     {
 531       vsize tilde = format.find ('~', i);
 532
 533       results.push_back (format.substr (i, (tilde - i)));
 534
 535       if (tilde == NPOS)
 536         break;
 537
 538       tilde++;
 539
 540       char spec = format.at (tilde++);
 541       if (spec == '~')
 542         results.push_back ("~");
 543       else
 544         {
 545           if (!scm_is_pair (rest))
 546             {
 547               programming_error (string (__FUNCTION__)
 548                                  + ": not enough arguments for format.");
 549               return ly_string2scm ("");
 550             }
 551
 552           SCM arg = scm_car (rest);
 553           rest = scm_cdr (rest);
 554
 555           int precision = 8;
 556
 557           if (spec == '$')
 558             precision = 2;
 559           else if (isdigit (spec))
 560             {
 561               precision = spec - '0';
 562               spec = format.at (tilde++);
 563             }
 564
 565           if (spec == 'a' || spec == 'A' || spec == 'f' || spec == '$')
 566             results.push_back (format_single_argument (arg, precision));
 567           else if (spec == 's' || spec == 'S')
 568             results.push_back (format_single_argument (arg, precision, true));
 569           else if (spec == 'l')
 570             {
 571               SCM s = arg;
 572               for (; scm_is_pair (s); s = scm_cdr (s))
 573                 {
 574                   results.push_back (format_single_argument (scm_car (s), precision));
 575                   if (!scm_is_null (scm_cdr (s)))
 576                     results.push_back (" ");
 577                 }
 578
 579               if (!scm_is_null (s))
 580                 results.push_back (format_single_argument (s, precision));
 581
 582             }
 583         }
 584
 585       i = tilde;
 586     }
 587
 588   if (scm_is_pair (rest))
 589     programming_error (string (__FUNCTION__)
 590                        + ": too many arguments");
 591
 592   vsize len = 0;
 593   for (vsize i = 0; i < results.size (); i++)
 594     len += results[i].size ();
 595
 596   char *result = (char *) scm_malloc (len + 1);
 597   char *ptr = result;
 598   for (vsize i = 0; i < results.size (); i++)
 599     {
 600       strncpy (ptr, results[i].c_str (), results[i].size ());
 601       ptr += results[i].size ();
 602     }
 603   *ptr = '\0';
 604
 605   return scm_take_locale_stringn (result, len);
 606 }
 607
 608 int
 609 ly_run_command (char *argv[], char **standard_output, char **standard_error)
 610 {
 611   GError *error = 0;
 612   int exit_status = 0;
 613   int flags = G_SPAWN_SEARCH_PATH;
 614   if (!standard_output)
 615     flags |= G_SPAWN_STDOUT_TO_DEV_NULL;
 616   if (!standard_error)
 617     flags |= G_SPAWN_STDERR_TO_DEV_NULL;
 618   if (!g_spawn_sync (0, argv, 0, GSpawnFlags (flags),
 619                      0, 0,
 620                      standard_output, standard_error,
 621                      &exit_status, &error))
 622     {
 623       fprintf (stderr, "failed (%d): %s: %s\n", exit_status, argv[0], error->message);
 624       g_error_free (error);
 625       if (!exit_status)
 626         exit_status = -1;
 627     }
 628
 629   return exit_status;
 630 }
 631
 632 static char *
 633 ly_scm2utf8 (SCM str)
 634 {
 635   char *p = ly_scm2str0 (str);
 636   char *g = g_locale_to_utf8 (p, -1, 0, 0, 0);
 637   free (p);
 638   return g;
 639 }
 640
 641 LY_DEFINE (ly_spawn, "ly:spawn",
 642            1, 0, 1, (SCM command, SCM rest),
 643            "Simple interface to g_spawn_sync"
 644            " @var{str}."
 645            "  The error is formatted with @code{format} and @var{rest}.")
 646
 647 {
 648   LY_ASSERT_TYPE (scm_is_string, command, 1);
 649
 650   int argc = scm_is_pair (rest) ? scm_ilength (rest) : 0;
 651   char **argv = new char*[argc + 2];
 652
 653   int n = 0;
 654   argv[n++] = ly_scm2utf8 (command);
 655   for (SCM s = rest; scm_is_pair (s); s = scm_cdr (s))
 656     argv[n++] = ly_scm2utf8 (scm_car (s));
 657   argv[n] = 0;
 658
 659   char *standard_output = 0;
 660   char *standard_error = 0;
 661   // Always get the pointer to the stdout/stderr messages
 662   int exit_status = ly_run_command (argv, &standard_output, &standard_error);
 663
 664   // Print out stdout and stderr only in debug mode
 665   debug_output (string ("\n") + standard_output + standard_error, true);
 666
 667   for (int i = 0; i < n; i++)
 668     free (argv[i]);
 669   delete[] argv;
 670
 671   return scm_from_int (exit_status);
 672 }