Changeset 79538

Timestamp:

06/16/11 16:41:48 (4 years ago)

Author:

cal@…

Message:

rev-upgrade: new pextlib command to find out whether a file is binary

File:

• branches/gsoc11-rev-upgrade/base/src/pextlib1.0/Pextlib.c (modified) (4 diffs)

branches/gsoc11-rev-upgrade/base/src/pextlib1.0/Pextlib.c

@@ -47 +47 @@
 #include <limits.h>
 #include <pwd.h>
+#include <stdbool.h>
 #include <stdint.h>
 #include <stdio.h>
@@ -53 +54 @@
 #include <strings.h>
 #include <unistd.h>
+
+/*
+  people use this on non-mac systems
+  #include <mach-o/loader.h>
+  #include <mach-o/fat.h>
+*/
+#define MH_MAGIC    (0xfeedface)
+#define MH_MAGIC_64 (0xfeedfacf)
+#define FAT_MAGIC   (0xcafebabe)
 
 #include <tcl.h>
@@ -464 +474 @@
 }
 
+int fileIsBinaryCmd(ClientData clientData UNUSED, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
+    const char *path;
+    FILE *file;
+    uint32_t magic;
+    struct stat st;
+
+    if (objc != 2) {
+        Tcl_WrongNumArgs(interp, 1, objv, "filename");
+        return TCL_ERROR;
+    }
+
+    path = Tcl_GetString(objv[1]);
+    if (-1 == lstat(path, &st)) {
+        /* an error occured */
+        Tcl_SetErrno(errno);
+        Tcl_ResetResult(interp);
+        Tcl_AppendResult(interp, "lstat(", path, "):", (char *)Tcl_PosixError(interp), NULL);
+        return TCL_ERROR;
+    }
+    if (!S_ISREG(st.st_mode)) {
+        /* not a regular file, haven't seen directories which are binaries yet */
+        Tcl_SetObjResult(interp, Tcl_NewBooleanObj(false));
+        return TCL_OK;
+    }
+    if (NULL == (file = fopen(path, "r"))) {
+        Tcl_SetErrno(errno);
+        Tcl_ResetResult(interp);
+        Tcl_AppendResult(interp, "fopen(", path, "): ", (char *)Tcl_PosixError(interp), NULL);
+        return TCL_ERROR;
+    }
+    if (1 != fread(&magic, sizeof(uint32_t), 1, file)) {
+        if (feof(file)) {
+            fclose(file);
+            /* file is shorter than 4 byte, probably not a binary */
+            Tcl_SetObjResult(interp, Tcl_NewBooleanObj(false));
+            return TCL_OK;
+        }
+        /* error while reading */
+        Tcl_SetErrno(errno);
+        Tcl_ResetResult(interp);
+        Tcl_AppendResult(interp, "fread(&magic, 4, 1, ", path, "): ", (char *)Tcl_PosixError(interp), NULL);
+        fclose(file);
+        return TCL_ERROR;
+    }
+    if (magic == MH_MAGIC || magic == MH_MAGIC_64) {
+        fclose(file);
+        /* this is a mach-o file */
+        Tcl_SetObjResult(interp, Tcl_NewBooleanObj(true));
+        return TCL_OK;
+    }
+    if (magic == htonl(FAT_MAGIC)) {
+        uint32_t archcount;
+        /* either universal binary or java class (FAT_MAGIC == 0xcafebabe)
+           see /use/share/file/magic/cafebabe for an explanation of what I'm doing here */
+        if (1 != fread(&archcount, sizeof(uint32_t), 1, file)) {
+            if (feof(file)) {
+                fclose(file);
+                /* file shorter than 8 byte, probably not a binary either */
+                Tcl_SetObjResult(interp, Tcl_NewBooleanObj(false));
+                return TCL_OK;
+            }
+            /* error while reading */
+            Tcl_SetErrno(errno);
+            Tcl_ResetResult(interp);
+            Tcl_AppendResult(interp, "fread(&archcount, 4, 1, ", path, "): ", (char *)Tcl_PosixError(interp), NULL);
+            fclose(file);
+            return TCL_ERROR;
+        }
+
+        /* universal binary header is always big endian */
+        archcount = ntohl(archcount);
+        if (archcount > 0 && archcount < 20) {
+            fclose(file);
+            /* universal binary */
+            Tcl_SetObjResult(interp, Tcl_NewBooleanObj(true));
+            return TCL_OK;
+        }
+
+        fclose(file);
+        /* probably java class */
+        Tcl_SetObjResult(interp, Tcl_NewBooleanObj(false));
+        return TCL_OK;
+    }
+    fclose(file);
+
+    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(false));
+    return TCL_OK;
+}
+
+
 int Pextlib_Init(Tcl_Interp *interp)
 {
@@ -496 +596 @@
         Tcl_CreateObjCommand(interp, "unsetenv", UnsetEnvCmd, NULL, NULL);
         Tcl_CreateObjCommand(interp, "lchown", lchownCmd, NULL, NULL);
+        Tcl_CreateObjCommand(interp, "fileIsBinary", fileIsBinaryCmd, NULL, NULL);
         Tcl_CreateObjCommand(interp, "realpath", RealpathCmd, NULL, NULL);