Compare commits

...

2 Commits

  1. 10
      Makefile.in
  2. 17
      configure.ac
  3. 3
      ecl/Makefile
  4. 166
      ecl/clbird.lisp
  5. 43
      ecl/cldefs.h
  6. 14
      ecl/compile.lisp
  7. 363
      ecl/ecl.c
  8. 4
      nest/cmds.c
  9. 1
      nest/cmds.h
  10. 263
      sysdep/unix/main.c

10
Makefile.in

@ -22,6 +22,7 @@ RANLIB=@RANLIB@
INSTALL=@INSTALL@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
INSTALL_DATA=@INSTALL_DATA@
ECL=@ECL@
client=$(addprefix $(exedir)/,@CLIENT@)
daemon=$(exedir)/bird
@ -75,7 +76,7 @@ cli: $(client)
$(daemon): LIBS += $(DAEMON_LIBS)
# Include directories
dirs := client conf doc filter lib nest test $(addprefix proto/,$(protocols)) @sysdep_dirs@
dirs := client conf doc filter lib nest ecl test $(addprefix proto/,$(protocols)) @sysdep_dirs@
# conf/Makefile declarations needed for all other modules
conf-lex-targets := $(addprefix $(objdir)/conf/,cf-lex.o)
@ -165,6 +166,13 @@ $(objdir)/sysdep/paths.h: Makefile
echo >>$@ "#define PATH_CONTROL_SOCKET \"@CONTROL_SOCKET@\""
if test -n "@iproutedir@" ; then echo >>$@ "#define PATH_IPROUTE_DIR \"@iproutedir@\"" ; fi
$(objdir)/ecl/%.lisp: $(srcdir)/ecl/%.lisp
$(Q)cp $< $@
$(objdir)/ecl/lib%.a: $(objdir)/ecl/%.lisp $(srcdir)/ecl/compile.lisp
$(E)echo ECLC $< -> $@
$(Q)$(ECL) -norc -load $(srcdir)/ecl/compile.lisp -eval "(compile-clbird \"$<\" \"$@\")"
# Unit tests rules
tests_targets_ok = $(addsuffix .ok,$(tests_targets))

17
configure.ac

@ -169,6 +169,22 @@ if test "$bird_cflags_default" = yes ; then
BIRD_ADD_GCC_OPTION([bird_cv_c_option_wno_missing_init], [-Wno-missing-field-initializers])
fi
AC_CHECK_PROG([ECLCONFIG], [ecl-config], [ecl-config])
AC_CHECK_PROG([ECL], [ecl], [ecl])
test -z "$ECLCONFIG" && AC_MSG_ERROR([Embeddable Common Lisp is required.])
test -z "$ECL" && AC_MSG_ERROR([Embeddable Common Lisp is required.])
AC_SUBST([ECL])
AC_MSG_CHECKING([ecl-config CFLAGS])
ECLCFLAGS=`ecl-config --cflags`
AC_MSG_RESULT([$ECLCFLAGS])
AC_MSG_CHECKING([ecl-config LDFLAGS])
ECLLDFLAGS=`ecl-config --ldflags`
AC_MSG_RESULT([$ECLLDFLAGS])
CFLAGS="$CFLAGS $ECLCFLAGS"
LDFLAGS="$LDFLAGS $ECLLDFLAGS"
AC_MSG_CHECKING([CFLAGS])
AC_MSG_RESULT([$CFLAGS])
@ -465,6 +481,7 @@ AC_MSG_RESULT([ System configuration: $sysdesc])
AC_MSG_RESULT([ Debugging: $enable_debug])
AC_MSG_RESULT([ POSIX threads: $enable_pthreads])
AC_MSG_RESULT([ Routing protocols: $protocols])
AC_MSG_RESULT([ Embeddable Common Lisp: $ECL])
AC_MSG_RESULT([ LibSSH support in RPKI: $enable_libssh])
AC_MSG_RESULT([ Kernel MPLS support: $enable_mpls_kernel])
AC_MSG_RESULT([ Client: $enable_client])

3
ecl/Makefile

@ -0,0 +1,3 @@
src := ecl.c
obj := $(src-o-files) $(objdir)/$(s)/libclbird.a
$(all-daemon)

166
ecl/clbird.lisp

@ -0,0 +1,166 @@
(defpackage :bird-impl
(:use))
(defpackage :bird
(:nicknames :b)
(:use :cl)
(:export :version))
(in-package :bird)
(defclass bird-routing-table ()
((ptr
:initarg :ptr)))
(defmethod print-object ((obj bird-routing-table) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (ptr) obj
(format stream "\"~A\"" (bird-impl::table-name ptr)))))
(defun make-routing-table (ptr)
"Make a BIRD-ROUTING-TABLE from a foreign PTR."
(make-instance 'bird-routing-table
:ptr ptr))
(defclass bird-val ()
((ptr
:initarg :ptr)
(ty
:initarg :ty)))
(defun val-format (val)
"Formats VAL, a BIRD-VAL, to a string."
(bird-impl::format-val (slot-value val 'ptr)))
(defmethod print-object ((obj bird-val) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (ptr ty) obj
(format stream "~A \"~A\" ~A" (bird-impl::val-type-name ptr) (bird-impl::format-val ptr) ptr))))
(defclass bird-route ()
((ptr
:initarg :ptr)))
(defun make-route (ptr)
"Make a BIRD-ROUTE from a foreign PTR."
(make-instance 'bird-route
:ptr ptr))
(defclass val-pair (bird-val) ())
(defclass val-quad (bird-val) ())
(defclass val-ip (bird-val) ())
(defclass val-net (bird-val) ())
(defun bird-type-id-to-class (id)
"Returns a symbol for the given BIRD type ID. See filter/data.h."
(declare (fixnum id))
(case id
(#x12 'val-pair)
(#x13 'val-quad)
(#x20 'val-ip)
(#x21 'val-net)
(t 'bird-val)))
(defun make-bird-val (ptr)
"Make a BIRD-VAL from a foreign PTR."
(let* ((ty (bird-impl::val-type-id ptr))
(cls (bird-type-id-to-class ty))
(plain (make-instance 'bird-val
:ptr ptr
:ty ty)))
(change-class plain cls)))
(defun maybe-make-bird-val (obj)
"If OBJ is a foreign pointer, run MAKE-BIRD-VAL on it; otherwise, return OBJ."
(if (typep obj 'si::foreign-data)
(make-bird-val obj)
obj))
(defun make-pair (cell)
"Make a VAL-PAIR from a cons CELL."
(make-bird-val (bird-impl::make-val cell)))
(defun make-quad-int (int)
"Make a VAL-QUAD from a raw integer."
(make-bird-val (bird-impl::make-quad int)))
(defun make-quad-octets (&rest octets)
"Make a VAL-QUAD from a list of four OCTETS."
(make-bird-val (bird-impl::make-val octets)))
(defun cidr4 (o1 o2 o3 o4 prefix-len)
"Make a VAL-NET from 4 octets and a prefix length (i.e. o1.o2.o3.o4/prefix-len)"
(make-bird-val (bird-impl::cidr4 o1 o2 o3 o4 prefix-len)))
(defun bird-equal (val1 val2)
"Returns T if VAL1 is the same thing as VAL2 (both BIRD-VALs)."
(check-type val1 bird-val)
(check-type val2 bird-val)
(bird-impl::val-same (slot-value val1 'ptr)
(slot-value val2 'ptr)))
(defun bird-compare (val1 val2)
"Returns -1 (<), 0 (=), or 1 (>) as a comparison result for VAL1 and VAL2."
(check-type val1 bird-val)
(check-type val2 bird-val)
(bird-impl::val-compare (slot-value val1 'ptr)
(slot-value val2 'ptr)))
(defun val< (val1 val2) (eql (bird-compare val1 val2) -1))
(defun val> (val1 val2) (eql (bird-compare val1 val2) 1))
(defun val= (val1 val2) (bird-equal val1 val2))
(defun val>= (val1 val2) (member (bird-compare val1 val2) '(0 1)))
(defun val<= (val1 val2) (member (bird-compare val1 val2) '(0 -1)))
(defun val~ (val1 val2)
"Returns T if VAL1 is in the range VAL2 (both BIRD-VALs)."
(check-type val1 bird-val)
(check-type val2 bird-val)
(bird-impl::val-in-range (slot-value val1 'ptr)
(slot-value val2 'ptr)))
(defun routing-tables ()
"Get all of the BIRD routing tables."
(mapcar #'make-routing-table (bird-impl::routing-tables)))
(defun table-routes (table)
"Get the routes for the routing table TABLE."
(check-type table bird-routing-table)
(mapcar #'make-route (bird-impl::table-routes (slot-value table 'ptr))))
(defun table-routes-for (table prefix)
"Get the routes for the prefix PREFIX in the routing table TABLE."
(check-type table bird-routing-table)
(check-type prefix val-net)
(mapcar #'make-route (bird-impl::table-routes-net
(slot-value table 'ptr)
(slot-value prefix 'ptr))))
(defun route-attr (route attr)
"Get a route attribute."
(check-type route bird-route)
(maybe-make-bird-val (bird-impl::get-val attr (slot-value route 'ptr))))
(defmethod print-object ((obj bird-route) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (ptr ty) obj
(format stream "for ~A proto ~A (~A)"
(val-format (route-attr obj :net))
(val-format (route-attr obj :proto))
ptr))))
(defun router-id ()
"Returns the running BIRD router ID, as a VAL-QUAD."
(make-quad-int (bird-impl::router-id)))
(defun version ()
"Returns the running BIRD version, as a string."
(bird-impl::version))
(defun hostname ()
"Returns the hostname BIRD is running on, as a string."
(bird-impl::hostname))
(eval-when (:load-toplevel)
(format t "CL bird stuff is going brr~%"))

43
ecl/cldefs.h

@ -0,0 +1,43 @@
/*
* Embeddable Common Lisp support for BIRD
*
* (c) 2021 eta <hi@theta.eu.org>
*/
#ifndef _BIRD_CLDEFS_H_
#define _BIRD_CLDEFS_H_
#include <ecl/ecl.h>
#define ecls(x) ecl_make_simple_base_string(x,-1)
#define eclk(x) ecl_make_keyword(x)
#define eclcs(x) ecl_make_constant_base_string(x,-1)
// from libclbird.a
extern void clbird_native_lisp_init(cl_object);
cl_object clbird_version(void);
cl_object clbird_hostname(void);
cl_object clbird_router_id(void);
cl_object clbird_nullptr(void);
cl_object clbird_format_val(cl_object obj);
cl_object clbird_get_val(cl_object which, cl_object rte_obj);
cl_object clbird_get_routing_tables(void);
cl_object clbird_get_table_name(cl_object obj);
cl_object clbird_val_type_name(cl_object val_obj);
cl_object clbird_val_type_id(cl_object val_obj);
cl_object clbird_get_table_routes_all(cl_object table_obj);
cl_object clbird_get_table_routes_net(cl_object table_obj, cl_object net_obj);
cl_object clbird_dotquad(cl_object o1, cl_object o2, cl_object o3, cl_object o4);
cl_object clbird_cidr4(cl_object o1, cl_object o2, cl_object o3, cl_object o4, cl_object len);
cl_object clbird_val_compare(cl_object val1_obj, cl_object val2_obj);
cl_object clbird_val_same(cl_object val1_obj, cl_object val2_obj);
cl_object clbird_val_in_range(cl_object val1_obj, cl_object val2_obj);
cl_object clbird_make_val(cl_object from);
cl_object clbird_make_quad(cl_object from);
cl_object ea_to_object(eattr *e);
cl_object clbird_get_eattrs(cl_object rte_obj);
void init_ecl_functions(void);
void clbird_init(int, char**);
#endif

14
ecl/compile.lisp

@ -0,0 +1,14 @@
(require 'cmp)
(defun compile-clbird (&optional (source "clbird.lisp") (afile "clbird.a"))
(let* ((src-length (length source))
;; HACK(eta): what the heck
(c::+static-library-format+ "~a.a")
(cursed-obj-file (concatenate 'string
(subseq source 0 (- src-length 4))
"o")))
(compile-file source :system-p t)
(c::build-static-library afile
:lisp-files (list cursed-obj-file)
:init-name "clbird_native_lisp_init")
(quit)))

363
ecl/ecl.c

@ -0,0 +1,363 @@
/*
* Embeddable Common Lisp support for BIRD
*
* (c) 2021 eta <hi@theta.eu.org>
*/
#include <ecl/ecl.h>
#include "nest/bird.h"
#include "lib/lists.h"
#include "lib/resource.h"
#include "lib/socket.h"
#include "lib/event.h"
#include "lib/timer.h"
#include "lib/string.h"
#include "nest/route.h"
#include "nest/protocol.h"
#include "nest/iface.h"
#include "nest/cli.h"
#include "nest/locks.h"
#include "conf/conf.h"
#include "filter/filter.h"
#include "filter/data.h"
#include "cldefs.h"
cl_object
clbird_version()
{
return eclcs(BIRD_VERSION);
}
cl_object
clbird_hostname()
{
return ecls(config->hostname);
}
cl_object
clbird_router_id()
{
return ecl_make_fixnum(config->router_id);
}
cl_object
clbird_nullptr()
{
return ecl_make_pointer(NULL);
}
cl_object
clbird_format_val(cl_object obj)
{
struct f_val *val = ecl_foreign_data_pointer_safe(obj);
buffer buf;
LOG_BUFFER_INIT(buf);
val_format(val, &buf);
return ecls(buf.start);
}
cl_object
clbird_get_val(cl_object which, cl_object rte_obj)
{
struct rte *rte = ecl_foreign_data_pointer_safe(rte_obj);
struct f_val *res = ecl_alloc(sizeof(struct f_val));
struct rta *rta = rte->attrs;
cl_object ret = NULL;
if (ecl_eql(which, eclk("FROM"))) {
res->type = T_IP;
res->val.ip = rta->from;
}
else if (ecl_eql(which, eclk("GW"))) {
res->type = T_IP;
res->val.ip = rta->nh.gw;
}
else if (ecl_eql(which, eclk("NET"))) {
res->type = T_NET;
res->val.net = rte->net->n.addr;
}
else if (ecl_eql(which, eclk("PROTO"))) {
ret = ecls(rta->src->proto->name);
}
else if (ecl_eql(which, eclk("SOURCE"))) {
res->type = T_ENUM_RTS;
res->val.i = rta->source;
}
else if (ecl_eql(which, eclk("SCOPE"))) {
res->type = T_ENUM_SCOPE;
res->val.i = rta->scope;
}
else if (ecl_eql(which, eclk("DEST"))) {
res->type = T_ENUM_RTD;
res->val.i = rta->dest;
}
else if (ecl_eql(which, eclk("IFNAME"))) {
ret = rta->nh.iface ? ecls(rta->nh.iface->name) : ECL_NIL;
}
else if (ecl_eql(which, eclk("IFINDEX"))) {
ret = rta->nh.iface ? ecl_make_fixnum(rta->nh.iface->index) : ECL_NIL;
}
else if (ecl_eql(which, eclk("WEIGHT"))) {
ret = ecl_make_fixnum(rta->nh.weight + 1);
}
else {
FEerror("Unknown route attribute ~A.", 1, which);
}
if (ret != NULL) {
return ret;
}
else {
return ecl_make_pointer(res);
}
}
cl_object
clbird_get_routing_tables()
{
cl_object ret = ECL_NIL;
for (int i = 1; i < NET_MAX; i++) {
if (config->def_tables[i]) {
ret = ecl_cons(ecl_make_pointer(config->def_tables[i]->table), ret);
}
}
return ret;
}
cl_object
clbird_get_table_name(cl_object obj)
{
rtable *table = ecl_foreign_data_pointer_safe(obj);
return ecls(table->name);
}
cl_object
clbird_val_type_name(cl_object val_obj)
{
struct f_val *val = ecl_foreign_data_pointer_safe(val_obj);
return eclcs(f_type_name(val->type));
}
cl_object
clbird_val_type_id(cl_object val_obj)
{
struct f_val *val = ecl_foreign_data_pointer_safe(val_obj);
return ecl_make_fixnum(val->type);
}
cl_object
clbird_get_table_routes_all(cl_object table_obj)
{
rtable *table = ecl_foreign_data_pointer_safe(table_obj);
cl_object ret = ECL_NIL;
FIB_WALK(&table->fib, net, n)
{
for (rte *e = n->routes; e; e = e->next) {
ret = ecl_cons(ecl_make_pointer(e), ret);
}
}
FIB_WALK_END;
return ret;
}
cl_object
clbird_get_table_routes_net(cl_object table_obj, cl_object net_obj)
{
rtable *table = ecl_foreign_data_pointer_safe(table_obj);
struct f_val *net_val = ecl_foreign_data_pointer_safe(net_obj);
if (net_val->type != T_NET) {
FEerror("TABLE-ROUTES-NET needs a prefix, not a ~A", 1, clbird_val_type_name(net_obj));
}
const net_addr* na = net_val->val.net;
net* net = net_route(table, na);
if (!net) {
return ECL_NIL;
}
cl_object ret = ECL_NIL;
for (rte *e = net->routes; e; e = e->next) {
ret = ecl_cons(ecl_make_pointer(e), ret);
}
return ret;
}
cl_object
clbird_dotquad(cl_object o1, cl_object o2, cl_object o3, cl_object o4)
{
cl_fixnum ret = 0;
ret |= ecl_to_fix(o1) << 24;
ret |= ecl_to_fix(o2) << 16;
ret |= ecl_to_fix(o3) << 8;
ret |= ecl_to_fix(o4);
return ecl_make_fixnum(ret);
}
cl_object
clbird_cidr4(cl_object o1, cl_object o2, cl_object o3, cl_object o4, cl_object len)
{
cl_fixnum ret = 0;
ret |= ecl_to_fix(o1) << 24;
ret |= ecl_to_fix(o2) << 16;
ret |= ecl_to_fix(o3) << 8;
ret |= ecl_to_fix(o4);
net_addr *na = ecl_alloc(sizeof(net_addr));
net_fill_ip4(na, ret, ecl_to_fix(len));
struct f_val *res = ecl_alloc(sizeof(struct f_val));
res->type = T_NET;
res->val.net = na;
return ecl_make_pointer(res);
}
cl_object
clbird_val_compare(cl_object val1_obj, cl_object val2_obj)
{
struct f_val *val1 = ecl_foreign_data_pointer_safe(val1_obj);
struct f_val *val2 = ecl_foreign_data_pointer_safe(val2_obj);
cl_fixnum ret = val_compare(val1, val2);
if (ret == F_CMP_ERROR) {
FEerror("Comparison of raw BIRD values ~A (~A) and ~A (~A) failed.", 4, val1_obj, eclcs(f_type_name(val1->type)), val2_obj, eclcs(f_type_name(val2->type)));
}
return ecl_make_fixnum(ret);
}
cl_object
clbird_val_same(cl_object val1_obj, cl_object val2_obj)
{
struct f_val *val1 = ecl_foreign_data_pointer_safe(val1_obj);
struct f_val *val2 = ecl_foreign_data_pointer_safe(val2_obj);
return val_same(val1, val2) ? ECL_T : ECL_NIL;
}
cl_object
clbird_val_in_range(cl_object val1_obj, cl_object val2_obj)
{
struct f_val *val1 = ecl_foreign_data_pointer_safe(val1_obj);
struct f_val *val2 = ecl_foreign_data_pointer_safe(val2_obj);
cl_fixnum ret = val_in_range(val1, val2);
if (ret == F_CMP_ERROR) {
FEerror("Comparison of raw BIRD values ~A (~A) and ~A (~A) failed.", 4, val1_obj, eclcs(f_type_name(val1->type)), val2_obj, eclcs(f_type_name(val2->type)));
}
return ret ? ECL_T : ECL_NIL;
}
cl_object
clbird_make_quad(cl_object from)
{
struct f_val *res = ecl_alloc(sizeof(struct f_val));
res->type = T_QUAD;
res->val.i = ecl_to_fix(from);
return ecl_make_pointer(res);
}
cl_object
clbird_make_val(cl_object from)
{
struct f_val *res = ecl_alloc(sizeof(struct f_val));
if (ECL_FIXNUMP(from)) {
res->type = T_INT;
res->val.i = ecl_to_fix(from);
}
else if (ECL_STRINGP(from)) {
cl_object base = si_coerce_to_base_string(from);
res->type = T_STRING;
res->val.s = base->base_string.self;
}
else if (from == ECL_NIL || from == ECL_T) {
res->type = T_BOOL;
res->val.i = from == ECL_T ? 1 : 0;
}
else if (ECL_CONSP(from) && ECL_FIXNUMP(ECL_CONS_CAR(from)) && ECL_FIXNUMP(ECL_CONS_CDR(from))) {
res->type = T_PAIR;
res->val.i = ecl_to_fix(ECL_CONS_CAR(from)) << 16 | ecl_to_fix(ECL_CONS_CDR(from));
}
else if (ECL_LISTP(from) && ecl_length(from) == 4) {
res->type = T_QUAD;
res->val.i = ecl_to_fix(ecl_elt(from, 0)) << 24 | ecl_to_fix(ecl_elt(from, 1)) << 16 | ecl_to_fix(ecl_elt(from, 2)) << 8 | ecl_to_fix(ecl_elt(from, 3));
}
else {
FEerror("Don't know how to convert to BIRD value: ~A", 1, from);
}
return ecl_make_pointer(res);
}
cl_object
ea_to_object(eattr *e)
{
struct f_val *res = ecl_alloc(sizeof(struct f_val));
switch (e->type & EAF_TYPE_MASK) {
case EAF_TYPE_INT:
return ecl_make_fixnum(e->u.data);
case EAF_TYPE_ROUTER_ID:
res->type = T_QUAD;
res->val.i = e->u.data;
break;
case EAF_TYPE_OPAQUE:
return eclk("OPAQUE");
case EAF_TYPE_IP_ADDRESS:
res->type = T_IP;
res->val.ip = *((ip_addr *) e->u.ptr->data);
break;
case EAF_TYPE_AS_PATH:
res->type = T_PATH;
res->val.ad = e->u.ptr;
break;
case EAF_TYPE_BITFIELD:
return ecl_make_fixnum(e->u.data);
break;
case EAF_TYPE_INT_SET:
res->type = T_CLIST;
res->val.ad = e->u.ptr;
break;
case EAF_TYPE_EC_SET:
res->type = T_ECLIST;
res->val.ad = e->u.ptr;
break;
case EAF_TYPE_LC_SET:
res->type = T_LCLIST;
res->val.ad = e->u.ptr;
break;
case EAF_TYPE_UNDEF:
return ECL_NIL;
break;
default:
FEerror("failed to translate BIRD dynamic attribute of type ~A", 1, ecl_make_fixnum(e->type));
}
return ecl_make_pointer(res);
}
cl_object
clbird_get_eattrs(cl_object rte_obj)
{
struct rte *rte = ecl_foreign_data_pointer_safe(rte_obj);
cl_object ret = ECL_NIL;
for (ea_list *eal = rte->attrs->eattrs; eal; eal=eal->next) {
for (int i = 0; i < eal->count; i++) {
eattr *e = &eal->attrs[i];
cl_object id = ecl_make_fixnum(e->id);
cl_object attr = ecl_cons(id, ea_to_object(e));
ret = ecl_cons(attr, ret);
}
}
return ret;
}
void
init_ecl_functions()
{
cl_object package = ecl_find_package("BIRD-IMPL");
ecl_def_c_function(_ecl_intern("VERSION", package), clbird_version, 0);
ecl_def_c_function(_ecl_intern("HOSTNAME", package), clbird_hostname, 0);
ecl_def_c_function(_ecl_intern("ROUTER-ID", package), clbird_router_id, 0);
ecl_def_c_function(_ecl_intern("NULLPTR", package), clbird_nullptr, 0);
ecl_def_c_function(_ecl_intern("FORMAT-VAL", package), clbird_format_val, 1);
ecl_def_c_function(_ecl_intern("GET-VAL", package), clbird_get_val, 2);
ecl_def_c_function(_ecl_intern("ROUTING-TABLES", package), clbird_get_routing_tables, 0);
ecl_def_c_function(_ecl_intern("TABLE-NAME", package), clbird_get_table_name, 1);
ecl_def_c_function(_ecl_intern("TABLE-ROUTES", package), clbird_get_table_routes_all, 1);
ecl_def_c_function(_ecl_intern("TABLE-ROUTES-NET", package), clbird_get_table_routes_net, 2);
ecl_def_c_function(_ecl_intern("DOTQUAD", package), clbird_dotquad, 4);
ecl_def_c_function(_ecl_intern("CIDR4", package), clbird_cidr4, 5);
ecl_def_c_function(_ecl_intern("MAKE-VAL", package), clbird_make_val, 1);
ecl_def_c_function(_ecl_intern("MAKE-QUAD", package), clbird_make_quad, 1);
ecl_def_c_function(_ecl_intern("ROUTE-EATTRS", package), clbird_get_eattrs, 1);
ecl_def_c_function(_ecl_intern("VAL-TYPE-NAME", package), clbird_val_type_name, 1);
ecl_def_c_function(_ecl_intern("VAL-TYPE-ID", package), clbird_val_type_id, 1);
ecl_def_c_function(_ecl_intern("VAL-COMPARE", package), clbird_val_compare, 2);
ecl_def_c_function(_ecl_intern("VAL-SAME", package), clbird_val_same, 2);
ecl_def_c_function(_ecl_intern("VAL-IN-RANGE", package), clbird_val_in_range, 2);
}
void
clbird_init(int argc, char **argv)
{
ecl_set_option(ECL_OPT_TRAP_SIGSEGV, FALSE);
ecl_set_option(ECL_OPT_TRAP_SIGFPE, FALSE);
ecl_set_option(ECL_OPT_TRAP_SIGINT, FALSE);
ecl_set_option(ECL_OPT_TRAP_SIGILL, FALSE);
ecl_set_option(ECL_OPT_TRAP_INTERRUPT_SIGNAL, FALSE);
cl_boot(argc, argv);
ecl_init_module(NULL, clbird_native_lisp_init);
init_ecl_functions();
}

4
nest/cmds.c

@ -111,6 +111,7 @@ cmd_eval(const struct f_line *expr)
cli_msg(23, "%s", buf.start);
}
char* ecl_get_string_for(cl_object obj) {
// FIXME: handle errors in the printer
cl_object formatted = cl_princ_to_string(obj);
assert(ECL_STRINGP(formatted));
if (!ecl_fits_in_base_string(formatted)) {
@ -121,8 +122,7 @@ char* ecl_get_string_for(cl_object obj) {
return ret;
}
void
cmd_cl_eval(char *obj)
void cmd_cl_eval(const char *obj)
{
cl_env_ptr env = ecl_process_env();
cl_object form = ecl_read_from_cstring_safe(obj, ECL_NIL);

1
nest/cmds.h

@ -19,3 +19,4 @@ void cmd_show_memory(void);
struct f_line;
void cmd_eval(const struct f_line *expr);
void cmd_cl_eval(const char *);

263
sysdep/unix/main.c

@ -39,6 +39,7 @@
#include "conf/conf.h"
#include "filter/filter.h"
#include "filter/data.h"
#include "ecl/cldefs.h"
#include "unix.h"
#include "krt.h"
@ -853,260 +854,6 @@ parse_args(int argc, char **argv)
}
}
#define ecls(x) ecl_make_simple_base_string(x,-1)
#define eclk(x) ecl_make_keyword(x)
#define eclcs(x) ecl_make_constant_base_string(x,-1)
cl_object
clbird_version()
{
return eclcs(BIRD_VERSION);
}
cl_object
clbird_hostname()
{
return ecls(config->hostname);
}
cl_object
clbird_router_id()
{
return ecl_make_integer(config->router_id);
}
cl_object
clbird_nullptr()
{
return ecl_make_pointer(NULL);
}
cl_object
clbird_format_val(cl_object obj)
{
struct f_val *val = ecl_foreign_data_pointer_safe(obj);
buffer buf;
LOG_BUFFER_INIT(buf);
val_format(val, &buf);
return ecls(buf.start);
}
cl_object
clbird_get_val(cl_object which, cl_object rte_obj)
{
struct rte *rte = ecl_foreign_data_pointer_safe(rte_obj);
struct f_val *res = cfg_alloc(sizeof(struct f_val));
struct rta *rta = rte->attrs;
cl_object ret = NULL;
if (ecl_eql(which, eclk("FROM"))) {
res->type = T_IP;
res->val.ip = rta->from;
}
else if (ecl_eql(which, eclk("GW"))) {
res->type = T_IP;
res->val.ip = rta->nh.gw;
}
else if (ecl_eql(which, eclk("NET"))) {
res->type = T_NET;
res->val.net = rte->net->n.addr;
}
else if (ecl_eql(which, eclk("PROTO"))) {
ret = ecls(rta->src->proto->name);
}
else if (ecl_eql(which, eclk("SOURCE"))) {
res->type = T_ENUM_RTS;
res->val.i = rta->source;
}
else if (ecl_eql(which, eclk("SCOPE"))) {
res->type = T_ENUM_SCOPE;
res->val.i = rta->scope;
}
else if (ecl_eql(which, eclk("DEST"))) {
res->type = T_ENUM_RTD;
res->val.i = rta->dest;
}
else if (ecl_eql(which, eclk("IFNAME"))) {
ret = rta->nh.iface ? ecls(rta->nh.iface->name) : ECL_NIL;
}
else if (ecl_eql(which, eclk("IFINDEX"))) {
ret = rta->nh.iface ? ecl_make_integer(rta->nh.iface->index) : ECL_NIL;
}
else if (ecl_eql(which, eclk("WEIGHT"))) {
ret = ecl_make_integer(rta->nh.weight + 1);
}
else {
FEerror("Unknown route attribute ~A.", 1, which);
}
if (ret != NULL) {
return ret;
}
else {
return ecl_make_pointer(res);
}
}
cl_object
clbird_get_routing_tables()
{
cl_object ret = ECL_NIL;
for (int i = 1; i < NET_MAX; i++) {
if (config->def_tables[i]) {
ret = ecl_cons(ecl_make_pointer(config->def_tables[i]->table), ret);
}
}
return ret;
}
cl_object
clbird_get_table_name(cl_object obj)
{
rtable *table = ecl_foreign_data_pointer_safe(obj);
return ecls(table->name);
}
cl_object
clbird_val_type_name(cl_object val_obj)
{
struct f_val *val = ecl_foreign_data_pointer_safe(val_obj);
return eclcs(f_type_name(val->type));
}
cl_object
clbird_get_table_routes_all(cl_object table_obj)
{
rtable *table = ecl_foreign_data_pointer_safe(table_obj);
cl_object ret = ECL_NIL;
FIB_WALK(&table->fib, net, n)
{
for (rte *e = n->routes; e; e = e->next) {
ret = ecl_cons(ecl_make_pointer(e), ret);
}
}
FIB_WALK_END;
return ret;
}
cl_object
clbird_get_table_routes_net(cl_object table_obj, cl_object net_obj)
{
rtable *table = ecl_foreign_data_pointer_safe(table_obj);
struct f_val *net_val = ecl_foreign_data_pointer_safe(net_obj);
if (net_val->type != T_NET) {
FEerror("TABLE-ROUTES-NET needs a prefix, not a ~A", 1, clbird_val_type_name(net_obj));
}
net_addr* na = net_val->val.net;
net* net = net_route(table, na);
if (!net) {
return ECL_NIL;
}
cl_object ret = ECL_NIL;
for (rte *e = net->routes; e; e = e->next) {
ret = ecl_cons(ecl_make_pointer(e), ret);
}
return ret;
}
cl_object
clbird_dotquad(cl_object o1, cl_object o2, cl_object o3, cl_object o4)
{
cl_fixnum ret = 0;
ret |= ecl_to_fix(o1) << 24;
ret |= ecl_to_fix(o2) << 16;
ret |= ecl_to_fix(o3) << 8;
ret |= ecl_to_fix(o4);
return ecl_make_integer(ret);
}
cl_object
clbird_cidr4(cl_object o1, cl_object o2, cl_object o3, cl_object o4, cl_object len)
{
cl_fixnum ret = 0;
ret |= ecl_to_fix(o1) << 24;
ret |= ecl_to_fix(o2) << 16;
ret |= ecl_to_fix(o3) << 8;
ret |= ecl_to_fix(o4);
net_addr *na = cfg_alloc(sizeof(net_addr));
net_fill_ip4(na, ret, ecl_to_fix(len));
struct f_val *res = cfg_alloc(sizeof(struct f_val));
res->type = T_NET;
res->val.net = na;
return ecl_make_pointer(res);
}
cl_object
clbird_val_compare(cl_object val1_obj, cl_object val2_obj)
{
struct f_val *val1 = ecl_foreign_data_pointer_safe(val1_obj);
struct f_val *val2 = ecl_foreign_data_pointer_safe(val2_obj);
cl_fixnum ret = val_compare(val1, val2);
if (ret == F_CMP_ERROR) {
FEerror("Comparison of raw BIRD values ~A (~A) and ~A (~A) failed.", 4, val1_obj, eclcs(f_type_name(val1->type)), val2_obj, eclcs(f_type_name(val2->type)));
}
return ecl_make_integer(ret);
}
cl_object
clbird_val_same(cl_object val1_obj, cl_object val2_obj)
{
struct f_val *val1 = ecl_foreign_data_pointer_safe(val1_obj);
struct f_val *val2 = ecl_foreign_data_pointer_safe(val2_obj);
return val_same(val1, val2) ? ECL_T : ECL_NIL;
}
cl_object
clbird_val_in_range(cl_object val1_obj, cl_object val2_obj)
{
struct f_val *val1 = ecl_foreign_data_pointer_safe(val1_obj);
struct f_val *val2 = ecl_foreign_data_pointer_safe(val2_obj);
cl_fixnum ret = val_in_range(val1, val2);
if (ret == F_CMP_ERROR) {
FEerror("Comparison of raw BIRD values ~A (~A) and ~A (~A) failed.", 4, val1_obj, eclcs(f_type_name(val1->type)), val2_obj, eclcs(f_type_name(val2->type)));
}
return ret ? ECL_T : ECL_NIL;
}
cl_object
clbird_make_val(cl_object from)
{
struct f_val *res = cfg_alloc(sizeof(struct f_val));
if (ECL_FIXNUMP(from)) {
res->type = T_INT;
res->val.i = ecl_to_fix(from);
}
else if (ECL_STRINGP(from)) {
cl_object base = si_coerce_to_base_string(from);
res->type = T_STRING;
res->val.s = base->base_string.self;
}
else if (from == ECL_NIL || from == ECL_T) {
res->type = T_BOOL;
res->val.i = from == ECL_T ? 1 : 0;
}
else if (ECL_CONSP(from) && ECL_FIXNUMP(ECL_CONS_CAR(from)) && ECL_FIXNUMP(ECL_CONS_CDR(from))) {
res->type = T_PAIR;
res->val.i = ecl_to_fix(ECL_CONS_CAR(from)) << 16 | ecl_to_fix(ECL_CONS_CDR(from));
}
else if (ECL_LISTP(from) && ecl_length(from) == 4) {
res->type = T_QUAD;
res->val.i = ecl_to_fix(ecl_elt(from, 0)) << 24 | ecl_to_fix(ecl_elt(from, 1)) << 16 | ecl_to_fix(ecl_elt(from, 2)) << 8 | ecl_to_fix(ecl_elt(from, 3));
}
else {
FEerror("Don't know how to convert to BIRD value: ~A", 1, from);
}
return ecl_make_pointer(res);
}
void
init_ecl_functions()
{
cl_object package = ecl_make_package(eclcs("BIRD"), ECL_NIL, ECL_NIL, ECL_NIL);
ecl_def_c_function(_ecl_intern("VERSION", package), clbird_version, 0);
ecl_def_c_function(_ecl_intern("HOSTNAME", package), clbird_hostname, 0);
ecl_def_c_function(_ecl_intern("ROUTER-ID", package), clbird_router_id, 0);
ecl_def_c_function(_ecl_intern("NULLPTR", package), clbird_nullptr, 0);
ecl_def_c_function(_ecl_intern("FORMAT-VAL", package), clbird_format_val, 1);
ecl_def_c_function(_ecl_intern("GET-VAL", package), clbird_get_val, 2);
ecl_def_c_function(_ecl_intern("ROUTING-TABLES", package), clbird_get_routing_tables, 0);
ecl_def_c_function(_ecl_intern("TABLE-NAME", package), clbird_get_table_name, 1);
ecl_def_c_function(_ecl_intern("TABLE-ROUTES", package), clbird_get_table_routes_all, 1);
ecl_def_c_function(_ecl_intern("TABLE-ROUTES-NET", package), clbird_get_table_routes_net, 2);
ecl_def_c_function(_ecl_intern("DOTQUAD", package), clbird_dotquad, 4);
ecl_def_c_function(_ecl_intern("CIDR4", package), clbird_cidr4, 5);
ecl_def_c_function(_ecl_intern("MAKE-VAL", package), clbird_make_val, 1);
ecl_def_c_function(_ecl_intern("VAL-TYPE-NAME", package), clbird_val_type_name, 1);
ecl_def_c_function(_ecl_intern("VAL-COMPARE", package), clbird_val_compare, 2);
ecl_def_c_function(_ecl_intern("VAL-SAME", package), clbird_val_same, 2);
ecl_def_c_function(_ecl_intern("VAL-IN-RANGE", package), clbird_val_in_range, 2);
}
/*
* Hic Est main()
*/
@ -1180,13 +927,7 @@ main(int argc, char **argv)
log(L_INFO "Booting ECL");
ecl_set_option(ECL_OPT_TRAP_SIGSEGV, FALSE);
ecl_set_option(ECL_OPT_TRAP_SIGFPE, FALSE);
ecl_set_option(ECL_OPT_TRAP_SIGINT, FALSE);
ecl_set_option(ECL_OPT_TRAP_SIGILL, FALSE);
ecl_set_option(ECL_OPT_TRAP_INTERRUPT_SIGNAL, FALSE);
cl_boot(argc, argv);
init_ecl_functions();
clbird_init(argc, argv);
log(L_INFO "ECL interpreter booted");

Loading…
Cancel
Save