lily/general-scheme.cc

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