ldcache: new vocab for reading and parsing the /etc/ld.so.cache file

extra/ldcache/ldcache-docs.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2017 Björn Lindqvist.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax strings ;
+IN: ldcache
+
+HELP: search
+{ $values
+  { "entries" { $sequence ldcache-entry } }
+  { "namespec" "library name" }
+  { "arch" "architecture" }
+  { "entry/f" { $maybe ldcache-entry } }
+}
+{ $description "Searches among the entries for an entry with a matching name and architecture." } ;
+
+HELP: find-so
+{ $values { "namespec" "library name" } { "so-name/f" { $maybe string } } }
+{ $description "Looks up the library named 'namespec' from the system cache." } ;
+
+ARTICLE: "ldcache" "ldcache"
+"Vocab for interfacing with the '/etc/ld.so.cache' Unix file." ;
+
+ABOUT: "ldcache"

extra/ldcache/ldcache-tests.factor

@@ -0,0 +1,28 @@
+USING: accessors ldcache system tools.test ;
+IN: ldcache.tests
+
+: entries ( -- entries )
+    {
+        T{ ldcache-entry
+           { elf? t }
+           { arch x86.64 }
+           { osversion 0 }
+           { hwcap 0 }
+           { key "libwmf-0.2.so.7" }
+           { value "/usr/lib/x86_64-linux-gnu/libwmf-0.2.so.7" }
+         }
+        T{ ldcache-entry
+           { elf? t }
+           { arch x86.64 }
+           { osversion 0 }
+           { hwcap 0 }
+           { key "libwinpr-utils.so.0.1" }
+           { value
+             "/usr/lib/x86_64-linux-gnu/libwinpr-utils.so.0.1"
+           }
+         }
+    } ;
+
+{ "libwmf-0.2.so.7" } [
+    entries "wmf-0.2" x86.64 search key>>
+] unit-test

extra/ldcache/ldcache.factor

@@ -0,0 +1,91 @@
+! Copyright (C) 2017 Björn Lindqvist.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.strings assocs byte-arrays
+classes.struct fry io io.encodings.binary io.encodings.string io.files
+kernel math math.bitwise sequences system ;
+IN: ldcache
+
+! General util
+ERROR: bad-magic got expected ;
+
+: check-magic ( got expected -- )
+    2dup = [ 2drop ] [ bad-magic ] if ;
+
+CONSTANT: HEADER_MAGIC_OLD "ld.so-1.7.0"
+CONSTANT: HEADER_MAGIC_NEW "glibc-ld.so.cache1.1"
+
+TUPLE: ldcache-entry elf? arch osversion hwcap key value ;
+
+STRUCT: HeaderOld
+    { magic char[11] }
+    { nlibs uint32_t } ;
+
+STRUCT: EntryOld
+    { flags int32_t }
+    { key uint32_t }
+    { value uint32_t } ;
+
+STRUCT: HeaderNew
+    { magic char[20] }
+    { nlibs uint32_t }
+    { stringslen uint32_t }
+    { unused uint32_t[5] } ;
+
+STRUCT: EntryNew
+    { flags int16_t }
+    { key uint32_t }
+    { value uint32_t }
+    { osversion uint32_t }
+    { hwcap uint64_t } ;
+
+: check-ldcache-magic ( header expected -- )
+    [ magic>> ] dip [ >byte-array ] bi@ check-magic ;
+
+: make-string ( string-table i -- str )
+    0 rot swapd [ index-from ] 2keep swapd subseq
+    native-string-encoding decode ;
+
+: string-offset ( header-new -- n )
+    nlibs>> EntryNew struct-size * HeaderNew struct-size + ;
+
+: subtract-string-offset ( ofs entry-new -- entry-new )
+    over '[ _ - ] change-key swap '[ _ - ] change-value ;
+
+: parse-new-entries ( header-new -- seq )
+    [ string-offset ] keep
+    nlibs>> [ EntryNew read-struct ] replicate
+    [ subtract-string-offset ] with map ;
+
+: flag>arch ( flag -- arch )
+    0xff00 bitand
+    { { 0x0800 x86.32 }
+      { 0x0300 x86.64 }
+      { 0x0500 ppc.64 }
+    } at ;
+
+: <ldcache-entry> ( string-table entry-new -- entry )
+    [
+        nip [
+            flags>> [ 1 mask? ] [ flag>arch ] bi
+        ] [ osversion>> ] [ hwcap>> ] tri
+    ]
+    [ key>> make-string ]
+    [ value>> make-string ] 2tri ldcache-entry boa ;
+
+: parse ( -- entries  )
+    ! Read the old header and jump past it.
+    HeaderOld read-struct
+    [ HEADER_MAGIC_OLD check-ldcache-magic ]
+    [ nlibs>> EntryOld struct-size * seek-relative seek-input ] bi
+    HeaderNew read-struct
+    [ HEADER_MAGIC_NEW check-ldcache-magic ] keep
+    [ parse-new-entries ]
+    [ stringslen>> read ] bi
+    swap [ <ldcache-entry> ] with map ;
+
+: search ( entries namespec arch -- entry/f )
+    swap "lib" ".so" surround '[ [ arch>> _ = ] [ key>> _ head? ] bi and ] find nip ;
+
+: find-so ( namespec -- so-name/f )
+    [ "/etc/ld.so.cache" binary [ parse ] with-file-reader ] dip
+    cpu search [ key>> ] [ f ] if* ;