libgeda/src/scheme_attrib.c

   1 /* gEDA - GPL Electronic Design Automation
   2  * libgeda - gEDA's library - Scheme API
   3  * Copyright (C) 2010-2011 Peter Brett <peter@peter-b.co.uk>
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
  18  */
  19
  20 /*!
  21  * \file scheme_attrib.c
  22  * \brief Scheme API attribute manipulation procedures.
  23  */
  24
  25 #include <config.h>
  26
  27 #include "libgeda_priv.h"
  28 #include "libgedaguile_priv.h"
  29
  30 SCM_SYMBOL (attribute_format_sym, "attribute-format");
  31
  32 /*! \brief Parse an attribute text object into name and value strings.
  33  * \par Function Description
  34  * Tries to parse the underlying string of the text object \a text_s
  35  * into name and value strings.  If successful, returns a pair of the
  36  * form <tt>(name . value)</tt>.  Otherwise, raises an
  37  * <tt>attribute-format</tt> error.
  38  *
  39  * \note Scheme API: Implements the %attrib-parse procedure of the
  40  * (geda core attrib) module.
  41  *
  42  * \param text_s text object to attempt to split.
  43  * \return name/value pair, or SCM_BOOL_F.
  44  */
  45 SCM_DEFINE (parse_attrib, "%parse-attrib", 1, 0, 0,
  46             (SCM text_s), "Parse attribute name and value from text object.")
  47 {
  48   gchar *name = NULL;
  49   gchar *value = NULL;
  50   SCM result = SCM_BOOL_F;
  51
  52   SCM_ASSERT (edascm_is_object_type (text_s, OBJ_TEXT), text_s,
  53               SCM_ARG1, s_parse_attrib);
  54
  55   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  56   OBJECT *text = edascm_to_object (text_s);
  57
  58   scm_dynwind_begin (0);
  59   scm_dynwind_unwind_handler (g_free, name, SCM_F_WIND_EXPLICITLY);
  60   scm_dynwind_unwind_handler (g_free, value, SCM_F_WIND_EXPLICITLY);
  61
  62   if (o_attrib_get_name_value (text, &name, &value)) {
  63     result = scm_cons (scm_from_utf8_string (name),
  64                        scm_from_utf8_string (value));
  65   } else {
  66     scm_error (attribute_format_sym, s_parse_attrib,
  67                _("~A is not a valid attribute: invalid string '~A'."),
  68                scm_list_2 (text_s,
  69                            scm_from_utf8_string (o_text_get_string (toplevel, text))),
  70                SCM_EOL);
  71   }
  72   scm_dynwind_end ();
  73
  74   return result;
  75 }
  76
  77 /*! \brief Get a list of an object's attributes.
  78  * \par Function Description
  79  * Retrieves the attributes of the smob \a obj_s as a Scheme list of
  80  * #OBJECT smobs.
  81  *
  82  * \note Scheme API: Implements the %object-attribs procedure of the
  83  * (geda core attrib) module.
  84  *
  85  * \param obj_s object to get attributes for.
  86  * \return a list of #OBJECT smobs.
  87  */
  88 SCM_DEFINE (object_attribs, "%object-attribs", 1, 0, 0,
  89             (SCM obj_s), "Get an object's attributes.")
  90 {
  91   /* Ensure that the argument is an object */
  92   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
  93               SCM_ARG1, s_object_attribs);
  94
  95   OBJECT *obj = edascm_to_object (obj_s);
  96
  97   return edascm_from_object_glist (obj->attribs);
  98 }
  99
 100 /*! \brief Get the object that an attribute is attached to.
 101  * \par Function Description
 102  * Returns the #OBJECT smob that \a attrib_s is attached to.  If \a
 103  * attrib_s is not attached as an attribute, returns SCM_BOOL_F.
 104  *
 105  * \note Scheme API: Implements the %attrib-attachment procedure of
 106  * the (geda core attrib) module.
 107  *
 108  * \param attrib_s the object to get attribute attachment for.
 109  * \return the object to which \a attrib_s is attached, or SCM_BOOL_F.
 110  */
 111 SCM_DEFINE (attrib_attachment, "%attrib-attachment", 1, 0, 0,
 112             (SCM attrib_s), "Get the object that an attribute is attached to.")
 113 {
 114   /* Ensure that the argument is an object */
 115   SCM_ASSERT (EDASCM_OBJECTP (attrib_s), attrib_s,
 116               SCM_ARG1, s_attrib_attachment);
 117
 118   OBJECT *obj = edascm_to_object (attrib_s);
 119
 120   if (obj->attached_to == NULL) {
 121     return SCM_BOOL_F;
 122   } else {
 123     return edascm_from_object (obj->attached_to);
 124   }
 125 }
 126
 127 /*! \brief Attach an attribute to an object.
 128  * \par Function Description
 129  * Attach \a attrib_s to \a obj_s.  The following conditions must be
 130  * satisfied:
 131  *
 132  * - Neither \a obj_s nor \a attrib_s may be already attached as an
 133  *   attribute.
 134  * - Both \a obj_s and \a attrib_s must be part of the same page
 135  *   and/or complex object. (They can't be "loose" objects).
 136  * - \a attrib_s must be a text object.
 137  *
 138  * These restrictions are intentionally harsher than those of the C
 139  * API, and are required in order to ensure that the Scheme API is
 140  * safe.
 141  *
 142  * If \a attrib_s is already attached to \a obj_s, does nothing
 143  * successfully.
 144  *
 145  * \note Scheme API: Implements the %attach-attrib! procedure of
 146  * the (geda core attrib) module.
 147  *
 148  * \param obj_s the object to which to attach an attribute.
 149  * \param attrib_s the attribute to attach.
 150  * \return \a obj_s.
 151  */
 152 SCM_DEFINE (attach_attrib_x, "%attach-attrib!", 2, 0, 0,
 153             (SCM obj_s, SCM attrib_s), "Attach an attribute to an object.")
 154 {
 155   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
 156               SCM_ARG1, s_attach_attrib_x);
 157   SCM_ASSERT (edascm_is_object_type (attrib_s, OBJ_TEXT), attrib_s,
 158               SCM_ARG2, s_attach_attrib_x);
 159
 160   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 161   OBJECT *obj = edascm_to_object (obj_s);
 162   OBJECT *attrib = edascm_to_object (attrib_s);
 163
 164   /* Check that attachment doesn't already exist */
 165   if (attrib->attached_to == obj) return obj_s;
 166
 167   /* Check that both are in the same page and/or complex object */
 168   if ((obj->parent != attrib->parent)
 169       || (o_get_page (toplevel, obj) != o_get_page (toplevel, attrib))
 170       || ((obj->parent == NULL) && (o_get_page (toplevel, obj) == NULL))) {
 171     scm_error (edascm_object_state_sym, s_attach_attrib_x,
 172                _("Objects ~A and ~A are not part of the same page and/or complex object"),
 173                scm_list_2 (obj_s, attrib_s), SCM_EOL);
 174   }
 175
 176   /* Check that neither is already an attached attribute */
 177   if (obj->attached_to != NULL) {
 178     scm_error (edascm_object_state_sym, s_attach_attrib_x,
 179                _("Object ~A is already attached as an attribute"),
 180                scm_list_1 (obj_s), SCM_EOL);
 181   }
 182   if (attrib->attached_to != NULL) {
 183     scm_error (edascm_object_state_sym, s_attach_attrib_x,
 184                _("Object ~A is already attached as an attribute"),
 185                scm_list_1 (attrib_s), SCM_EOL);
 186   }
 187
 188   /* Carry out the attachment */
 189   o_emit_pre_change_notify (toplevel, attrib);
 190   o_attrib_attach (toplevel, attrib, obj, TRUE);
 191   o_emit_change_notify (toplevel, attrib);
 192
 193   o_page_changed (toplevel, obj);
 194
 195   scm_remember_upto_here_1 (attrib_s);
 196   return obj_s;
 197 }
 198
 199 /*! \brief Detach an attribute from an object.
 200  * \par Function Description
 201  * Detach \a attrib_s from \a obj_s.  If \a attrib_s is not attached
 202  * as an attribute, does nothing silently.  If \a attrib_s is attached
 203  * as an attribute of an object other than \a obj_s, throws a Scheme
 204  * error.
 205  *
 206  * \note Scheme API: Implements the %detach-attrib! procedure of
 207  * the (geda core attrib) module.
 208  *
 209  * \param obj_s the object from which to detach an attribute.
 210  * \param attrib_s the attribute to detach.
 211  * \return \a attrib_s.
 212  */
 213 SCM_DEFINE (detach_attrib_x, "%detach-attrib!", 2, 0, 0,
 214             (SCM obj_s, SCM attrib_s), "Detach an attribute to an object.")
 215 {
 216   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
 217               SCM_ARG1, s_detach_attrib_x);
 218   SCM_ASSERT (edascm_is_object_type (attrib_s, OBJ_TEXT), attrib_s,
 219               SCM_ARG2, s_detach_attrib_x);
 220
 221   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 222   OBJECT *obj = edascm_to_object (obj_s);
 223   OBJECT *attrib = edascm_to_object (attrib_s);
 224
 225   /* If attrib isn't attached, do nothing */
 226   if (attrib->attached_to == NULL) {
 227     return obj_s;
 228   }
 229
 230   /* Check that attrib isn't attached elsewhere */
 231   if (attrib->attached_to != obj) {
 232     scm_error (edascm_object_state_sym, s_detach_attrib_x,
 233                _("Object ~A is attribute of wrong object"),
 234                scm_list_1 (attrib_s), SCM_EOL);
 235   }
 236
 237   /* Detach object */
 238   o_emit_pre_change_notify (toplevel, attrib);
 239   o_attrib_remove (toplevel, &obj->attribs, attrib);
 240   o_set_color (toplevel, attrib, DETACHED_ATTRIBUTE_COLOR);
 241   o_emit_change_notify (toplevel, attrib);
 242
 243   o_page_changed (toplevel, obj);
 244
 245   scm_remember_upto_here_1 (attrib_s);
 246   return obj_s;
 247 }
 248
 249 /*! \brief Get a complex object's promotable attribs.
 250  * \par Function Description
 251  * Returns the promotable attributes of \a complex_s, according to the
 252  * current gEDA configuration.
 253  *
 254  * \param complex_s the complex object for which to get promotable
 255  *                  attributes.
 256  * \return a list of promotable attributes.
 257  */
 258 SCM_DEFINE (promotable_attribs, "%promotable-attribs", 1, 0, 0,
 259             (SCM complex_s), "Get a component's promotable attributes")
 260 {
 261   SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
 262               SCM_ARG1, s_promotable_attribs);
 263
 264   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 265   OBJECT *obj = edascm_to_object (complex_s);
 266
 267   GList *lst = o_complex_get_promotable (toplevel, obj, FALSE);
 268
 269   return edascm_from_object_glist (lst);
 270 }
 271
 272
 273 /*!
 274  * \brief Create the (geda core attrib) Scheme module.
 275  * \par Function Description
 276  * Defines procedures in the (geda core attrib) module. The module can
 277  * be accessed using (use-modules (geda core attrib)).
 278  */
 279 static void
 280 init_module_geda_core_attrib ()
 281 {
 282   /* Register the functions */
 283   #include "scheme_attrib.x"
 284
 285   /* Add them to the module's public definitions. */
 286   scm_c_export (s_parse_attrib, s_object_attribs, s_attrib_attachment,
 287                 s_attach_attrib_x, s_detach_attrib_x,
 288                 s_promotable_attribs,
 289                 NULL);
 290 }
 291
 292 /*!
 293  * \brief Initialise the basic gEDA attribute manipulation procedures.
 294  * \par Function Description
 295  * Registers some Scheme procedures for working with
 296  * attributes. Should only be called by scheme_api_init().
 297  */
 298 void
 299 edascm_init_attrib ()
 300 {
 301   /* Define the (geda core attrib) module */
 302   scm_c_define_module ("geda core attrib",
 303                        init_module_geda_core_attrib,
 304                        NULL);
 305 }