1 ; file: lock-objs.scm
  2 ; type: lepton-schematic Guile script
  3 ; copyright (c) 2020-2023 dmn <graahnul.grom@ya.ru>
  4 ; license: GPLv2+
  5 ;
  6 ; Locks all objects with lock=yes attribute on startup.
  7 ; Allows to keep any objects locked (not only components).
  8 ;
  9 ; Usage:
 10 ; Add the following to your gschemrc file:
 11 ;   ( primitive-load "/path/to/lock-objs.scm" )
 12 ;
 13 
 14 
 15 
 16 ( use-modules ( lepton object  ) )
 17 ( use-modules ( lepton attrib  ) )
 18 ( use-modules ( lepton page    ) )
 19 ( use-modules ( lepton log     ) )
 20 ( use-modules ( schematic hook ) )
 21 
 22 
 23 
 24 ( define ( msg level msg . aa )
 25     ; ( format #t "lock-objs.scm [~a]: ~a~%" level (apply format #f msg aa) )
 26     ( log!
 27         ( if (eq? level 'error) 'warning 'message )
 28         "lock-objs.scm [~a]: ~a"
 29         level
 30         ( apply format #f msg aa )
 31     )
 32 ) ; msg()
 33 
 34 
 35 
 36 ( define ( is_obj_lockable obj )
 37 
 38     ( define ( is_attr_lock_yes attr )
 39         ; return:
 40         ( and
 41             ( attribute? attr )
 42             ( string-ci=? (attrib-name attr)  "lock" )
 43             ( string-ci=? (attrib-value attr) "yes"  )
 44         )
 45     )
 46 
 47     ; return:
 48     ( find is_attr_lock_yes (object-attribs obj) )
 49 
 50 ) ; is_obj_lockable()
 51 
 52 
 53 
 54 ( define ( lock_objs_on_page page )
 55 
 56     ( define ( lock_obj o )
 57         ( set-object-selectable! o #f )
 58     )
 59 
 60     ( define ( lock_obj_attrs o )
 61         ( for-each lock_obj (object-attribs o) )
 62     )
 63 
 64     ( define ( is_page_symbol page )
 65         ; return:
 66         ( string-suffix-ci? ".sym" (page-filename page) )
 67     )
 68 
 69     ( define ( do_lock )
 70         ( for-each
 71         ( lambda( obj )
 72             ( msg 'info "locking [~a]..." (object-type obj) )
 73             ( lock_obj obj )
 74             ( lock_obj_attrs obj )
 75             ( set-page-dirty! page #f )
 76         )
 77         ( filter is_obj_lockable (page-contents page) )
 78         )
 79     )
 80 
 81 
 82     ( if ( is_page_symbol page )
 83         ( msg 'info "disable locking in symbol files" ) ; if
 84         ( do_lock )                                   ; else
 85     )
 86 
 87 ) ; lock_objs_on_page()
 88 
 89 
 90 
 91 ( define ( install_hook )
 92     ( add-hook! open-page-hook lock_objs_on_page #f ) ; #f => prepend
 93     ( msg 'info "open-page-hook installed" )
 94 )
 95 
 96 
 97 
 98 
 99 ; open-page-hook:           added in    git 21a5b6b (20.12.2018)
100 ; set-object-selectable!(): added circa git 4708547 (16.01.2019)
101 ;
102 ( if ( and (defined? 'open-page-hook) (defined? 'set-object-selectable!) )
103     ( install_hook )
104     ( msg 'error "need lepton-eda >= git:4708547 (16.01.2019)" )
105 )
106