Re: Unsecure assoc calls

[Michael Käppler]

Here's the next revision.
> +      string key_string = ly_scm2string (scm_object_to_string (key,
> SCM_UNDEFINED));
>
> I think it's OK to leave out the print function argument, since it's optional.
>   
Are you sure? I tried this and IIRC it failed to compile. If I read the 
guile manual correctly, it is only in Scheme optional, but not in C.

Regards,
Michael

>From d49a99745e25b688bc1ef8dd44854bad95067adc Mon Sep 17 00:00:00 2001
From: =?utf-8?q?Michael=20K=C3=A4ppler?= <address@hidden>
Date: Sat, 12 Sep 2009 23:32:49 +0200
Subject: [PATCH] Improve error checking in ly:assoc-get and ly:chain-assoc-get.

* Introduce a new optional argument strict_checking

* When strict_checking is set to true, output a programming_error
  if the given key is not found in the given alist / achain.

* This patch does not change the current behaviour. It prepares
  a greater modification to remove all assoc calls through
  secure assoc-get calls.
---
 lily/general-scheme.cc     |   36 +++++++++++++++++++++++++++---------
 lily/include/lily-guile.hh |    4 ++--
 scm/lily-library.scm       |   17 ++---------------
 3 files changed, 31 insertions(+), 26 deletions(-)

diff --git a/lily/general-scheme.cc b/lily/general-scheme.cc
index 43ff745..93e47af 100644
--- a/lily/general-scheme.cc
+++ b/lily/general-scheme.cc
@@ -154,10 +154,12 @@ LY_DEFINE (ly_dir_p, "ly:dir?",
 }
 
 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
-          2, 1, 0,
-          (SCM key, SCM alist, SCM default_value),
-          "Return value if @var{key} in @var{alist}, else @code{default-value}"
-          " (or @code{#f} if not specified).")
+          2, 2, 0,
+          (SCM key, SCM alist, SCM default_value, SCM strict_checking),
+          "Return value if @var{key} in @var{alist}, else @var{default-value}"
+          " (or @code{#f} if not specified).  If @var{strict-checking} is set"
+           " to @code{#t} and @var{key} is not in @var{alist}, a 
programming_error"
+           " is output.")
 {
   LY_ASSERT_TYPE(ly_cheap_is_list, alist, 2);
   
@@ -168,6 +170,13 @@ LY_DEFINE (ly_assoc_get, "ly:assoc-get",
   if (default_value == SCM_UNDEFINED)
     default_value = SCM_BOOL_F;
 
+  if (strict_checking == SCM_BOOL_T)
+    {
+      string key_string = ly_scm2string (scm_object_to_string (key, 
SCM_UNDEFINED));
+      string default_value_string = ly_scm2string (scm_object_to_string 
(default_value, SCM_UNDEFINED)); 
+      programming_error ("Cannot find key `" + key_string + "' in alist, 
setting to `" + default_value_string + "'.");
+    }
+
   return default_value;
 }
 
@@ -312,10 +321,11 @@ LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 }
 
 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
-          2, 1, 0, (SCM key, SCM achain, SCM val),
+          2, 2, 0, (SCM key, SCM achain, SCM default_value, SCM 
strict_checking),
           "Return value for @var{key} from a list of alists @var{achain}."
-          "  If no entry is found, return @var{val} or @code{#f} if"
-          " @var{val} is not specified.")
+          "  If no entry is found, return @var{default-value} or @code{#f} if"
+          " @var{default-value} is not specified.  With @var{strict-checking}"
+           " set to @code{#t}, a programming_error is output in such cases.")
 {
   if (scm_is_pair (achain))
     {
@@ -323,9 +333,17 @@ LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
       if (scm_is_pair (handle))
        return scm_cdr (handle);
       else
-       return ly_chain_assoc_get (key, scm_cdr (achain), val);
+       return ly_chain_assoc_get (key, scm_cdr (achain), default_value);
     }
-  return val == SCM_UNDEFINED ? SCM_BOOL_F : val;
+  
+  if (strict_checking == SCM_BOOL_T)
+    {
+      string key_string = ly_scm2string (scm_object_to_string (key, 
SCM_UNDEFINED));
+      string default_value_string = ly_scm2string (scm_object_to_string 
(default_value, SCM_UNDEFINED)); 
+      programming_error ("Cannot find key `" + key_string + "' in achain, 
setting to `" + default_value_string + "'.");
+    }
+
+  return default_value == SCM_UNDEFINED ? SCM_BOOL_F : default_value;
 }
 
 
diff --git a/lily/include/lily-guile.hh b/lily/include/lily-guile.hh
index 88c7fe8..859131a 100644
--- a/lily/include/lily-guile.hh
+++ b/lily/include/lily-guile.hh
@@ -48,9 +48,9 @@ SCM ly_rational2scm (Rational);
 SCM ly_offset2scm (Offset);
 Offset ly_scm2offset (SCM);
 SCM ly_chain_assoc (SCM key, SCM achain);
-SCM ly_chain_assoc_get (SCM key, SCM achain, SCM val);
+SCM ly_chain_assoc_get (SCM key, SCM achain, SCM default_value, SCM 
strict_checking = SCM_BOOL_F);
 SCM ly_assoc_cdr (SCM key, SCM alist);
-SCM ly_assoc_get (SCM key, SCM alist, SCM def);
+SCM ly_assoc_get (SCM key, SCM alist, SCM default_value, SCM strict_checking = 
SCM_BOOL_F);
 Interval ly_scm2interval (SCM);
 Drul_array<Real> ly_scm2realdrul (SCM);
 Slice int_list_to_slice (SCM l);
diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 335c345..827fb24 100644
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -197,6 +197,8 @@
 
 (define-public assoc-get ly:assoc-get)
 
+(define-public chain-assoc-get ly:chain-assoc-get)
+
 (define-public (uniqued-alist alist acc)
   (if (null? alist) acc
       (if (assoc (caar alist) acc)
@@ -207,21 +209,6 @@
   (string<? (symbol->string (car x))
            (symbol->string (car y))))
 
-(define-public (chain-assoc-get x alist-list . default)
-  "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
-found."
-
-  (define (helper x alist-list default)
-    (if (null? alist-list)
-       default
-       (let* ((handle (assoc x (car alist-list))))
-         (if (pair? handle)
-             (cdr handle)
-             (helper x (cdr alist-list) default)))))
-
-  (helper x alist-list
-         (if (pair? default) (car default) #f)))
-
 (define (map-alist-vals func list)
   "map FUNC over the vals of  LIST, leaving the keys."
   (if (null?  list)
-- 
1.6.0.2