From 34739522c0b020d76376cda081a2d139a79ea60a Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Sun, 20 Nov 2016 04:32:12 -0800 Subject: [PATCH] [utils] Add CTypes binding of fts and implement remove_directory_tree Summary: This diff adds a dependency on ctypes.foreign and uses the example binding of fts to implement remove_directory_tree. Reviewed By: yunxing Differential Revision: D4115569 fbshipit-source-id: 3509955 --- infer/src/Makefile | 5 +- infer/src/base/Utils.ml | 10 ++ infer/src/base/Utils.mli | 3 + infer/src/tp/fts/LICENSE | 19 +++ infer/src/tp/fts/fts.ml | 247 ++++++++++++++++++++++++++++++ infer/src/tp/fts/fts.mli | 315 +++++++++++++++++++++++++++++++++++++++ install-sh | 98 +++++------- opam | 2 + package.json | 2 + scripts/toplevel_init | 2 + yarn.lock | 70 ++++++++- 11 files changed, 707 insertions(+), 66 deletions(-) create mode 100644 infer/src/tp/fts/LICENSE create mode 100644 infer/src/tp/fts/fts.ml create mode 100644 infer/src/tp/fts/fts.mli diff --git a/infer/src/Makefile b/infer/src/Makefile index e8fa6358b..edb9fcb2d 100644 --- a/infer/src/Makefile +++ b/infer/src/Makefile @@ -26,6 +26,7 @@ OCAMLBUILD_OPTIONS = \ -r \ -use-menhir -menhir 'menhir --explain --strict'\ -use-ocamlfind \ + -lflags -cclib,-lffi \ -cflags -g -lflags -g \ -cflags -short-paths \ -cflags -safe-string \ @@ -35,7 +36,7 @@ OCAMLBUILD_OPTIONS = \ -cflags -w,$(OCAML_FATAL_WARNINGS)-4-9-40-41-42-45-48 \ -tag-line "<*{clang/clang_ast_*,backend/jsonbug_*,checkers/stacktree_*}>: warn(-27-32-35-39)" \ -tag thread \ - -pkgs atdgen,core,extlib,oUnit,str,unix,yojson,zip + -pkgs atdgen,core,ctypes.foreign,extlib,oUnit,str,unix,yojson,zip ifeq ($(ENABLE_OCAML_ANNOT),yes) OCAMLBUILD_OPTIONS += -cflags -annot @@ -133,7 +134,7 @@ else EXTRA_DEPS = opensource endif -DEPENDENCIES = IR backend base checkers eradicate harness integration quandary $(EXTRA_DEPS) +DEPENDENCIES = IR backend base checkers eradicate harness integration tp/fts quandary $(EXTRA_DEPS) # ocamlbuild command with options common to all build targets OCAMLBUILD_BASE = rebuild $(OCAMLBUILD_OPTIONS) -j $(NCPU) $(addprefix -I , $(DEPENDENCIES)) diff --git a/infer/src/base/Utils.ml b/infer/src/base/Utils.ml index 76e290fa2..2d4d33238 100644 --- a/infer/src/base/Utils.ml +++ b/infer/src/base/Utils.ml @@ -582,6 +582,16 @@ let directory_iter f path = else f path + +let remove_directory_tree path = + Stream.from (fun _ -> Fts.fts_read (Fts.fts_open ?compar:None ~path_argv:[path] ~options:[])) + |> Stream.iter (fun ent -> + match Fts.FTSENT.info ent with + | FTS_D | FTS_DOT -> () + | _ -> Core.Std.Unix.remove (Fts.FTSENT.name ent) + ) + + let string_crc_hex32 s = Digest.to_hex (Digest.string s) let string_append_crc_cutoff ?(cutoff=100) ?(key="") name = diff --git a/infer/src/base/Utils.mli b/infer/src/base/Utils.mli index d6c8ed8cf..e4d55e513 100644 --- a/infer/src/base/Utils.mli +++ b/infer/src/base/Utils.mli @@ -278,6 +278,9 @@ val directory_fold : ('a -> string -> 'a) -> 'a -> string -> 'a (** Functional iter function over all the file of a directory *) val directory_iter : (string -> unit) -> string -> unit +(** Remove a directory and its contents *) +val remove_directory_tree : string -> unit + val read_optional_json_file : string -> (Yojson.Basic.json, string) result val with_file : string -> f:(out_channel -> 'a) -> 'a diff --git a/infer/src/tp/fts/LICENSE b/infer/src/tp/fts/LICENSE new file mode 100644 index 000000000..c6bf872f4 --- /dev/null +++ b/infer/src/tp/fts/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013 Jeremy Yallop + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. \ No newline at end of file diff --git a/infer/src/tp/fts/fts.ml b/infer/src/tp/fts/fts.ml new file mode 100644 index 000000000..8343d6146 --- /dev/null +++ b/infer/src/tp/fts/fts.ml @@ -0,0 +1,247 @@ +(* + * Copyright (c) 2013 Jeremy Yallop. + * + * This file is distributed under the terms of the MIT License. + * See the file LICENSE for details. + *) + +open Ctypes + +type fts_info = + FTS_D + | FTS_DC + | FTS_DEFAULT + | FTS_DNR + | FTS_DOT + | FTS_DP + | FTS_ERR + | FTS_F + | FTS_NS + | FTS_NSOK + | FTS_SL + | FTS_SLNONE + +let fts_info_of_int = function + | 1 -> FTS_D + | 2 -> FTS_DC + | 3 -> FTS_DEFAULT + | 4 -> FTS_DNR + | 5 -> FTS_DOT + | 6 -> FTS_DP + | 7 -> FTS_ERR + | 8 -> FTS_F + (* | 9 -> FTS_INIT *) + | 10 -> FTS_NS + | 11 -> FTS_NSOK + | 12 -> FTS_SL + | 13 -> FTS_SLNONE + | _ -> invalid_arg "fts_info" + +type fts_open_option = + FTS_COMFOLLOW + | FTS_LOGICAL + | FTS_NOCHDIR + | FTS_NOSTAT + | FTS_PHYSICAL + | FTS_SEEDOT + | FTS_XDEV + +let fts_children_option_of_bool = function + | false -> 0 + | true -> 0x0100 + +let fts_open_option_value = function + | FTS_COMFOLLOW -> 0x0001 + | FTS_LOGICAL -> 0x0002 + | FTS_NOCHDIR -> 0x0004 + | FTS_NOSTAT -> 0x0008 + | FTS_PHYSICAL -> 0x0010 + | FTS_SEEDOT -> 0x0020 + | FTS_XDEV -> 0x0040 + +type fts_set_option = + FTS_AGAIN + | FTS_FOLLOW + | FTS_SKIP + +let fts_set_option_value = function + | FTS_AGAIN -> 1 + | FTS_FOLLOW -> 2 + | FTS_SKIP -> 4 + +let castp typ p = from_voidp typ (to_voidp p) + +module FTSENT = +struct + open PosixTypes + open Unsigned + + type ftsent + let ftsent : ftsent structure typ = structure "ftsent" + let ( -: ) ty label = field ftsent label ty + let fts_cycle = ptr ftsent -: "fts_cycle" + let fts_parent = ptr ftsent -: "fts_parent" + let fts_link = ptr ftsent -: "fts_link" + let fts_number = int -: "fts_number" + let fts_pointer = ptr void -: "fts_pointer" + let fts_accpath = string -: "fts_accpath" + let fts_path = string -: "fts_path" + let fts_errno = int -: "fts_errno" + let _fts_symfd = int -: "fts_symfd" + let _fts_pathlen = ushort -: "fts_pathlen" + let _fts_namelen = ushort -: "fts_namelen" + let _fts_ino = ino_t -: "fts_ino" + let _fts_dev = dev_t -: "fts_dev" + let _fts_nlink = nlink_t -: "fts_nlink" + let fts_level = short -: "fts_level" + let fts_info = ushort -: "fts_info" + let _fts_flags = ushort -: "fts_flags" + let _fts_instr = ushort -: "fts_instr" + let _fts_statp = ptr void -: "fts_statp" (* really a struct stat * *) + let fts_name = char -: "fts_name" + let () = seal ftsent + + type t = ftsent structure ptr + let t = ptr ftsent + + let info : t -> fts_info + = fun t -> fts_info_of_int (UShort.to_int (getf !@t fts_info)) + + let accpath : t -> string + = fun t -> getf !@t fts_accpath + + let path : t -> string + = fun t -> getf !@t fts_path + + let name : t -> string + = fun t -> Ctypes.coerce (ptr char) string (t |-> fts_name) + + let level : t -> int + = fun t -> getf !@t fts_level + + let errno : t -> int + = fun t -> getf !@t fts_errno + + let number : t -> int + = fun t -> getf !@t fts_number + + let set_number : t -> int -> unit + = fun t -> setf !@t fts_number + + let pointer : t -> unit ptr + = fun t -> getf !@t fts_pointer + + let set_pointer : t -> unit ptr -> unit + = fun t -> setf !@t fts_pointer + + let parent : t -> t + = fun t -> getf !@t fts_parent + + let link : t -> t + = fun t -> getf !@t fts_link + + let cycle : t -> t + = fun t -> getf !@t fts_cycle +end + +module FTS = +struct + open PosixTypes + open FTSENT + + type fts + let fts : fts structure typ = structure "fts" + let ( -: ) ty label = field fts label ty + let fts_cur = ptr ftsent -: "fts_cur" + let fts_child = ptr ftsent -: "fts_child" + let fts_array = ptr (ptr ftsent) -: "fts_array" + let fts_dev = dev_t -: "fts_dev" + let fts_path = string -: "fts_path" + let fts_rfd = int -: "fts_rfd" + let _fts_pathlen = int -: "fts_pathlen" + let fts_nitems = int -: "fts_nitems" + let _fts_compar = Foreign.funptr (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int) + -: "fts_compar" + (* fts_options would work well as a view *) + let _fts_options = int -: "fts_options" + let () = seal fts + + type t = { ptr : fts structure ptr; + (* The compar field ties the lifetime of the comparison function + to the lifetime of the fts object to prevent untimely + collection. *) + compar: (FTSENT.t ptr -> FTSENT.t ptr -> int) option } + + let cur : t -> FTSENT.t + = fun { ptr } -> getf !@ptr fts_cur + + let child : t -> FTSENT.t + = fun { ptr } -> getf !@ptr fts_child + + let array : t -> FTSENT.t list + = fun { ptr } -> + CArray.(to_list (from_ptr (getf !@ptr fts_array) (getf !@ptr fts_nitems))) + + let dev : t -> dev_t + = fun { ptr } -> getf !@ptr fts_dev + + let path : t -> string + = fun { ptr } -> getf !@ptr fts_path + + let rfd : t -> int + = fun { ptr } -> getf !@ptr fts_rfd +end + +open FTSENT +open FTS + +(* FTS *fts_open(char * const *path_argv, int options, + int ( *compar)(const FTSENT **, const FTSENT ** )); +*) +let compar_type = ptr FTSENT.t @-> ptr FTSENT.t @-> returning int +let _fts_open = Foreign.foreign "fts_open" + (ptr string @-> int @-> Foreign.funptr_opt compar_type @-> returning (ptr fts)) + +(* FTSENT *fts_read(FTS *ftsp); *) +let _fts_read = Foreign.foreign "fts_read" ~check_errno:true + (ptr fts @-> returning (ptr ftsent)) + +(* FTSENT *fts_children(FTS *ftsp, int options); *) +let _fts_children = Foreign.foreign "fts_children" + (ptr fts @-> int @-> returning (ptr ftsent)) + +(* int fts_set(FTS *ftsp, FTSENT *f, int options); *) +let _fts_set = Foreign.foreign "fts_set" ~check_errno:true + (ptr fts @-> ptr (ftsent) @-> int @-> returning int) + +(* int fts_close(FTS *ftsp); *) +let _fts_close = Foreign.foreign "fts_close" ~check_errno:true + (ptr fts @-> returning int) + +let crush_options f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 + +let fts_read fts = + let p = _fts_read fts.ptr in + if to_voidp p = null then None + else Some p + +let fts_close ftsp = + ignore (_fts_close ftsp.ptr) + +let fts_set ~ftsp ~f ~options = + ignore (_fts_set ftsp.ptr f (crush_options fts_set_option_value options)) + +let fts_children ~ftsp ~name_only = + _fts_children ftsp.ptr (fts_children_option_of_bool name_only) + +let null_terminated_array_of_ptr_list typ list = + let nitems = List.length list in + let arr = CArray.make typ (1 + nitems) in + List.iteri (CArray.set arr) list; + (castp (ptr void) (CArray.start arr +@ nitems)) <-@ null; + arr + +let fts_open ~path_argv ?compar ~options = + let paths = null_terminated_array_of_ptr_list string path_argv in + let options = crush_options fts_open_option_value options in + { ptr = _fts_open (CArray.start paths) options compar; compar } diff --git a/infer/src/tp/fts/fts.mli b/infer/src/tp/fts/fts.mli new file mode 100644 index 000000000..17b834a6c --- /dev/null +++ b/infer/src/tp/fts/fts.mli @@ -0,0 +1,315 @@ +(* + * Copyright (c) 2013 Jeremy Yallop. + * + * This file is distributed under the terms of the MIT License. + * See the file LICENSE for details. + *) + +open Ctypes + +(* The fts functions are provided for traversing file hierarchies. A simple + overview is that the fts_open() function returns a "handle" on a file + hierarchy, which is then supplied to the other fts functions. The function + fts_read() returns a pointer to a structure describing one of the files in the + file hierarchy. The function fts_children() returns a pointer to a linked + list of structures, each of which describes one of the files contained in a + directory in the hierarchy. In general, directories are visited two + distinguishable times; in preorder (before any of their descendants are + visited) and in postorder (after all of their descendants have been visited). + Files are visited once. It is possible to walk the hierarchy "logically" + (ignoring symbolic links) or physically (visiting symbolic links), order the + walk of the hierarchy or prune and/or revisit portions of the hierarchy. *) + +type fts_info = + (* A directory being visited in preorder. *) + FTS_D + + (* A directory that causes a cycle in the tree. (The fts_cycle field of + the FTSENT structure will be filled in as well.) *) + | FTS_DC + + (* Any FTSENT structure that represents a file type not explicitly + described by one of the other fts_info values. *) + | FTS_DEFAULT + + (* A directory which cannot be read. This is an error return, and the + fts_errno field will be set to indicate what caused the error. *) + | FTS_DNR + + (* A file named "." or ".." which was not specified as a filename to + fts_open() (see FTS_SEEDOT). *) + | FTS_DOT + + (* A directory being visited in postorder. The contents of the FTSENT + structure will be unchanged from when it was returned in preorder, that + is, with the fts_info field set to FTS_D. *) + | FTS_DP + + (* This is an error return, and the fts_errno field will be set to + indicate what caused the error. *) + | FTS_ERR + + (* A regular file. *) + | FTS_F + + (* A file for which no stat(2) information was available. The contents of + the fts_statp field are undefined. This is an error return, and the + fts_errno field will be set to indicate what caused the error. *) + | FTS_NS + + (* A file for which no stat(2) information was requested. The contents of + the fts_statp field are undefined. *) + | FTS_NSOK + + (* A symbolic link. *) + | FTS_SL + + (* A symbolic link with a nonexistent target. The contents of the + fts_statp field reference the file characteristic information for the + symbolic link itself. *) + | FTS_SLNONE + +module FTSENT : +sig + type t + + (* flags for FTSENT structure *) + val info : t -> fts_info + + (* A path for accessing the file from the current directory. *) + val accpath : t -> string + + (* The path for the file relative to the root of the traversal. This path + contains the path specified to fts_open() as a prefix. *) + val path : t -> string + + (* The name of the file. *) + val name : t -> string + + (* The depth of the traversal, numbered from -1 to N, where this file was + found. The FTSENT structure representing the parent of the starting point + (or root) of the traversal is numbered -1, and the FTSENT structure for + the root itself is numbered 0. *) + val level : t -> int + + (* Upon return of a FTSENT structure from the fts_children() or fts_read() + functions, with its fts_info field set to FTS_DNR, FTS_ERR or FTS_NS, + the fts_errno field contains the value of the external variable errno + specifying the cause of the error. Otherwise, the contents of the + fts_errno field are undefined. *) + val errno : t -> int + + (* This field is provided for the use of the application program and is + not modified by the fts functions. It is initialized to 0. *) + val number : t -> int + val set_number : t -> int -> unit + + (* This field is provided for the use of the application program and is + not modified by the fts functions. It is initialized to NULL. *) + val pointer : t -> unit ptr + val set_pointer : t -> unit ptr -> unit + + (* A pointer to the FTSENT structure referencing the file in the hierarchy + immediately above the current file, that is, the directory of which + this file is a member. A parent structure for the initial entry point + is provided as well, however, only the fts_level, fts_number and + fts_pointer fields are guaranteed to be initialized. *) + val parent : t -> t + + (* Upon return from the fts_children() function, the fts_link field points + to the next structure in the NULL-terminated linked list of directory + members. Otherwise, the contents of the fts_link field are undefined. *) + val link : t -> t + + (* If a directory causes a cycle in the hierarchy (see FTS_DC), either + because of a hard link between two directories, or a symbolic link + pointing to a directory, the fts_cycle field of the structure will + point to the FTSENT structure in the hierarchy that references the same + file as the current FTSENT structure. Otherwise, the contents of the + fts_cycle field are undefined. *) + val cycle : t -> t + + (* A pointer to stat(2) information for the file. *) + (* val statp : t -> stat *) +end + +module FTS : +sig + type t + + val cur : t -> FTSENT.t + + val child : t -> FTSENT.t + + val array : t -> FTSENT.t list + + val dev : t -> PosixTypes.dev_t + + val path : t -> string + + val rfd : t -> int +end + +type fts_open_option = + (* This option causes any symbolic link specified as a root path to be + followed immediately whether or not FTS_LOGICAL is also specified. *) + FTS_COMFOLLOW + + (* This option causes the fts routines to return FTSENT structures for the + targets of symbolic links instead of the symbolic links themselves. If + this option is set, the only symbolic links for which FTSENT structures + are returned to the application are those referencing nonexistent + files. Either FTS_LOGICAL or FTS_PHYSICAL must be provided to the + fts_open() function. *) + | FTS_LOGICAL + + (* As a performance optimization, the fts functions change directories as + they walk the file hierarchy. This has the side-effect that an + application cannot rely on being in any particular directory during the + traversal. The FTS_NOCHDIR option turns off this optimization, and the + fts functions will not change the current directory. Note that + applications should not themselves change their current directory and + try to access files unless FTS_NOCHDIR is specified and absolute + pathnames were provided as arguments to fts_open(). *) + | FTS_NOCHDIR + + (* By default, returned FTSENT structures reference file characteristic + information (the statp field) for each file visited. This option + relaxes that requirement as a performance optimization, allowing the + fts functions to set the fts_info field to FTS_NSOK and leave the + contents of the statp field undefined. *) + | FTS_NOSTAT + + (* This option causes the fts routines to return FTSENT structures for + symbolic links themselves instead of the target files they point to. If + this option is set, FTSENT structures for all symbolic links in the + hierarchy are returned to the application. Either FTS_LOGICAL or + FTS_PHYSICAL must be provided to the fts_open() function. *) + | FTS_PHYSICAL + + (* By default, unless they are specified as path arguments to fts_open(), + any files named "." or ".." encountered in the file hierarchy are + ignored. This option causes the fts routines to return FTSENT structures + for them. *) + | FTS_SEEDOT + + (* This option prevents fts from descending into directories that have a + different device number than the file from which the descent began. *) + | FTS_XDEV + + +(* The fts_open() function takes a list of strings naming one or more + paths which make up a logical file hierarchy to be traversed. + + There are a number of options, at least one of which (either FTS_LOGICAL + or FTS_PHYSICAL) must be specified. + + The argument compar() specifies a user-defined function which may be used + to order the traversal of the hierarchy. It takes two pointers to + pointers to FTSENT structures as arguments and should return a negative + value, zero, or a positive value to indicate if the file referenced by + its first argument comes before, in any order with respect to, or after, + the file referenced by its second argument. The fts_accpath, fts_path + and fts_pathlen fields of the FTSENT structures may never be used in this + comparison. If the fts_info field is set to FTS_NS or FTS_NSOK, the + fts_statp field may not either. If the compar() argument is NULL, the + directory traversal order is in the order listed in path_argv for the + root paths, and in the order listed in the directory for everything + else. *) +val fts_open : + path_argv:string list -> + ?compar:(FTSENT.t ptr -> FTSENT.t ptr -> int) -> + options:fts_open_option list -> + FTS.t + +(* The fts_children() function returns a pointer to an FTSENT structure + describing the first entry in a NULL-terminated linked list of the + files in the directory represented by the FTSENT structure most + recently returned by fts_read(). The list is linked through the + fts_link field of the FTSENT structure, and is ordered by the + user-specified comparison function, if any. Repeated calls to + fts_children() will recreate this linked list. + + As a special case, if fts_read() has not yet been called for a hierarchy, + fts_children() will return a pointer to the files in the logical + directory specified to fts_open(), that is, the arguments specified to + fts_open(). Otherwise, if the FTSENT structure most recently returned by + fts_read() is not a directory being visited in preorder, or the directory + does not contain any files, fts_children() returns NULL and sets errno to + zero. If an error occurs, fts_children() returns NULL and sets errno + appropriately. + + The FTSENT structures returned by fts_children() may be overwritten after + a call to fts_children(), fts_close() or fts_read() on the same file + hierarchy stream. + + The name_only option indicates that only the names of the files are + needed. The contents of all the fields in the returned linked list of + structures are undefined with the exception of the fts_name and + fts_namelen fields. +*) +val fts_children : + ftsp:FTS.t -> + name_only:bool -> + FTSENT.t + +(* The fts_read() function returns a pointer to an FTSENT structure + describing a file in the hierarchy. Directories (that are readable and do + not cause cycles) are visited at least twice, once in preorder and once in + postorder. All other files are visited at least once. (Hard links between + directories that do not cause cycles or symbolic links to symbolic links may + cause files to be visited more than once, or directories more than twice.) + + The FTSENT structures returned by fts_read() may be overwritten after a + call to fts_close() on the same file hierarchy stream, or, after a call to + fts_read() on the same file hierarchy stream unless they represent a file of + type directory, in which case they will not be overwritten until after a + call to fts_read() after the FTSENT structure has been returned by the + function fts_read() in postorder. *) +val fts_read : FTS.t -> FTSENT.t option + +type fts_set_option = + (* Re-visit the file; any file type may be revisited. The next call to + fts_read() will return the referenced file. The fts_stat and + fts_info fields of the structure will be reinitialized at that time, + but no other fields will have been changed. This option is + meaningful only for the most recently returned file from fts_read(). + Normal use is for postorder directory visits, where it causes the + directory to be revisited (in both preorder and postorder) as well as + all of its descendants. *) + FTS_AGAIN + + (* The referenced file must be a symbolic link. If the referenced file + is the one most recently returned by fts_read(), the next call to + fts_read() returns the file with the fts_info and fts_statp fields + reinitialized to reflect the target of the symbolic link instead of + the symbolic link itself. If the file is one of those most + recently returned by fts_children(), the fts_info and fts_statp + fields of the structure, when returned by fts_read(), will reflect + the target of the symbolic link instead of the symbolic link + itself. In either case, if the target of the symbolic link does + not exist the fields of the returned structure will be unchanged + and the fts_info field will be set to FTS_SLNONE. + + If the target of the link is a directory, the preorder return, followed + by the return of all of its descendants, followed by a postorder return, + is done. *) + | FTS_FOLLOW + + (* No descendants of this file are visited. The file may be one of + those most recently returned by either fts_children() or + fts_read(). *) + | FTS_SKIP + +(* The function fts_set() allows the user application to determine + further processing for the file f of the stream ftsp. *) +val fts_set : + ftsp:FTS.t -> + f:FTSENT.t -> + options:fts_set_option list -> + unit + +(* The fts_close() function closes a file hierarchy stream ftsp and + restores the current directory to the directory from which fts_open() + was called to open ftsp. *) +val fts_close : FTS.t -> unit diff --git a/install-sh b/install-sh index 377bb8687..f8b188cf3 100755 --- a/install-sh +++ b/install-sh @@ -1,7 +1,7 @@ #!/bin/sh # install - install a program, script, or datafile -scriptversion=2011-11-20.07; # UTC +scriptversion=2013-12-25.23; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the @@ -41,19 +41,15 @@ scriptversion=2011-11-20.07; # UTC # This script is compatible with the BSD install script, but was written # from scratch. +tab=' ' nl=' ' -IFS=" "" $nl" +IFS=" $tab$nl" -# set DOITPROG to echo to test this script +# Set DOITPROG to "echo" to test this script. -# Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} -if test -z "$doit"; then - doit_exec=exec -else - doit_exec=$doit -fi +doit_exec=${doit:-exec} # Put in absolute file names if you don't have them in your path; # or use environment vars. @@ -68,17 +64,6 @@ mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} -posix_glob='?' -initialize_posix_glob=' - test "$posix_glob" != "?" || { - if (set -f) 2>/dev/null; then - posix_glob= - else - posix_glob=: - fi - } -' - posix_mkdir= # Desired mode of installed file. @@ -97,7 +82,7 @@ dir_arg= dst_arg= copy_on_change=false -no_target_directory= +is_target_a_directory=possibly usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE @@ -143,8 +128,7 @@ while test $# -ne 0; do -m) mode=$2 case $mode in - *' '* | *' '* | *' -'* | *'*'* | *'?'* | *'['*) + *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac @@ -155,14 +139,16 @@ while test $# -ne 0; do -s) stripcmd=$stripprog;; - -t) dst_arg=$2 + -t) + is_target_a_directory=always + dst_arg=$2 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac shift;; - -T) no_target_directory=true;; + -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; @@ -177,6 +163,16 @@ while test $# -ne 0; do shift done +# We allow the use of options -d and -T together, by making -d +# take the precedence; this is for compatibility with GNU install. + +if test -n "$dir_arg"; then + if test -n "$dst_arg"; then + echo "$0: target directory not allowed when installing a directory." >&2 + exit 1 + fi +fi + if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. @@ -207,6 +203,15 @@ if test $# -eq 0; then exit 0 fi +if test -z "$dir_arg"; then + if test $# -gt 1 || test "$is_target_a_directory" = always; then + if test ! -d "$dst_arg"; then + echo "$0: $dst_arg: Is not a directory." >&2 + exit 1 + fi + fi +fi + if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 @@ -269,7 +274,7 @@ do # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then - if test -n "$no_target_directory"; then + if test "$is_target_a_directory" = never; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi @@ -277,33 +282,7 @@ do dst=$dstdir/`basename "$src"` dstdir_status=0 else - # Prefer dirname, but fall back on a substitute if dirname fails. - dstdir=` - (dirname "$dst") 2>/dev/null || - expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$dst" : 'X\(//\)[^/]' \| \ - X"$dst" : 'X\(//\)$' \| \ - X"$dst" : 'X\(/\)' \| . 2>/dev/null || - echo X"$dst" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q' - ` - + dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi @@ -396,14 +375,12 @@ do *) prefix='';; esac - eval "$initialize_posix_glob" - oIFS=$IFS IFS=/ - $posix_glob set -f + set -f set fnord $dstdir shift - $posix_glob set +f + set +f IFS=$oIFS prefixes= @@ -474,13 +451,10 @@ do if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && - - eval "$initialize_posix_glob" && - $posix_glob set -f && + set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && - $posix_glob set +f && - + set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then diff --git a/opam b/opam index a7a0895b2..2ac1bf191 100644 --- a/opam +++ b/opam @@ -29,6 +29,8 @@ depends: [ "atdgen" {>="1.6.0"} "core" {>="113.33.03"} "conf-autoconf" + "ctypes" {>="0.9.2"} + "ctypes-foreign" {>="0.4.0"} "extlib-compat" {>="1.5.4"} "javalib" {>="2.3.3"} "ocamlfind" {build} diff --git a/package.json b/package.json index be5b4cbf9..f7a25a29d 100644 --- a/package.json +++ b/package.json @@ -13,6 +13,8 @@ "dependencies": { "@opam-alpha/ocamlfind": "*", "@opam-alpha/core": "113.33.3", + "@opam-alpha/ctypes": "0.9.2", + "@opam-alpha/ctypes-foreign": "0.4.0", "@opam-alpha/ocaml": "4.2.3", "@opam-alpha/sawja": "^ 1.5.2", "@opam-alpha/atdgen": "^ 1.10.0", diff --git a/scripts/toplevel_init b/scripts/toplevel_init index 70c320a00..86383c577 100644 --- a/scripts/toplevel_init +++ b/scripts/toplevel_init @@ -2,6 +2,8 @@ #use "topfind";; #thread;; #require "core";; +#require "ctypes";; +#require "ctypes.foreign";; #require "sawja";; #require "atdgen";; #require "extlib";; diff --git a/yarn.lock b/yarn.lock index 7bf6a1e48..574a5e410 100644 --- a/yarn.lock +++ b/yarn.lock @@ -84,6 +84,12 @@ dependencies: conf-ncurses-actual "git://github.com/npm-opam/conf-ncurses.git#1.0.0" +"@opam-alpha/conf-pkg-config@*": + version "1.0.0" + resolved conf-pkg-config-1.0.0.tgz#938404a87215fdea094d5b16ccc44715c4dbac28 + dependencies: + conf-pkg-config-actual "git://github.com/npm-opam/conf-pkg-config.git#1.0.0" + "@opam-alpha/conf-which@*": version "1.0.0" resolved conf-which-1.0.0.tgz#45b4dc34e3c256b8027fc47d672eca0d1c25f541 @@ -108,6 +114,18 @@ dependencies: cppo-actual "git://github.com/npm-opam/cppo.git#1.4.0" +"@opam-alpha/ctypes-foreign@*", "@opam-alpha/ctypes-foreign@0.4.0": + version "0.4.0" + resolved ctypes-foreign-0.4.0.tgz#deb81969266b6436ca6b84699541a3e28b909ad1 + dependencies: + ctypes-foreign-actual "git://github.com/npm-opam/ctypes-foreign.git#0.4.0" + +"@opam-alpha/ctypes@0.9.2": + version "0.9.2" + resolved ctypes-0.9.2.tgz#b3eac49546bbd7e263643014a1f4993a4352cfee + dependencies: + ctypes-actual "git://github.com/npm-opam/ctypes.git#0.9.2" + "@opam-alpha/easy-format@*", "@opam-alpha/easy-format@^ 1.2.0": version "1.2.0" resolved easy-format-1.2.0.tgz#08d53c49a8227ae7d0dec0aa0f236d8fc913cd6b @@ -568,6 +586,16 @@ opam-installer-bin "https://github.com/yunxing/opam-installer-bin.git" substs "https://github.com/yunxing/substs.git" +"conf-pkg-config-actual@git://github.com/npm-opam/conf-pkg-config.git#1.0.0": + version "1.0.0" + resolved conf-pkg-config.git-b1306dce3be035308f7d8aabf8d579921e0ff821#11761f7a13f854172308800e9b110d6d4415814f + dependencies: + dependency-env "https://github.com/npm-ml/dependency-env.git" + nopam "https://github.com/yunxing/nopam.git" + opam-installer-bin "https://github.com/yunxing/opam-installer-bin.git" + substs "https://github.com/yunxing/substs.git" + yarn-pkg-config "*" + "conf-which-actual@git://github.com/npm-opam/conf-which.git#1.0.0": version "1.0.0" resolved conf-which.git-fdb919d8ed608aa090d0b95bbde5f3717192c068#03ef24339d749f817c328e42b8a992f92322d543 @@ -636,7 +664,31 @@ opam-installer-bin "https://github.com/yunxing/opam-installer-bin.git" substs "https://github.com/yunxing/substs.git" -"dependency-env@git+https://github.com/reasonml/dependency-env.git", "dependency-env@https://github.com/npm-ml/dependency-env.git", "dependencyEnv@git+https://github.com/reasonml/dependency-env.git": +"ctypes-actual@git://github.com/npm-opam/ctypes.git#0.9.2": + version "0.9.2" + resolved ctypes.git-c926f6199de1b5989189fb620f26cbd7892fe4f4#1d5be5cd1e2fe987d4431ee165115c15a81d78d0 + dependencies: + "@opam-alpha/conf-pkg-config" "*" + "@opam-alpha/ctypes-foreign" "*" + "@opam-alpha/lwt" "*" + "@opam-alpha/ocamlfind" "*" + "@opam-alpha/ounit" "*" + dependency-env "https://github.com/npm-ml/dependency-env.git" + nopam "https://github.com/yunxing/nopam.git" + opam-installer-bin "https://github.com/yunxing/opam-installer-bin.git" + substs "https://github.com/yunxing/substs.git" + +"ctypes-foreign-actual@git://github.com/npm-opam/ctypes-foreign.git#0.4.0": + version "0.4.0" + resolved ctypes-foreign.git-8f223221a7309520a5679f472eecd950b4647e11#591be30c209cf0f440d24b7262e88bbf559d1e6f + dependencies: + dependency-env "https://github.com/npm-ml/dependency-env.git" + libffi "*" + nopam "https://github.com/yunxing/nopam.git" + opam-installer-bin "https://github.com/yunxing/opam-installer-bin.git" + substs "https://github.com/yunxing/substs.git" + +"dependency-env@git+https://github.com/npm-ml/dependency-env.git", "dependency-env@git+https://github.com/reasonml/dependency-env.git", "dependency-env@https://github.com/npm-ml/dependency-env.git", "dependencyEnv@git+https://github.com/reasonml/dependency-env.git": version "0.0.0" resolved dependency-env.git-20ccabcf9f4854fdcda3f965ce410487515d7dc7#fb1a38d19682e7f754e6154d276ce6fdfbade9f7 dependencies: @@ -713,6 +765,13 @@ opam-installer-bin "https://github.com/yunxing/opam-installer-bin.git" substs "https://github.com/yunxing/substs.git" +libffi@*: + version "3.2.11" + resolved libffi-3.2.11.tgz#4d1d94dacae6c511c434ea50cc5d62ddcc97461e + dependencies: + dependency-env "https://github.com/npm-ml/dependency-env.git" + nopam "https://github.com/yunxing/nopam.git" + "lwt-actual@git://github.com/npm-opam/lwt.git#2.5.2": version "2.5.2" resolved lwt.git-6c677df6c9d6f34d6fc2d28680bbab7e95da23e4#a7c043ebfd0ae650a259191c60c583714cfa8ea2 @@ -763,7 +822,7 @@ opam-installer-bin "https://github.com/yunxing/opam-installer-bin.git" substs "https://github.com/yunxing/substs.git" -"nopam@git+https://github.com/reasonml/nopam.git", "nopam@https://github.com/yunxing/nopam.git": +"nopam@git+https://github.com/reasonml/nopam.git", "nopam@git+https://github.com/yunxing/nopam.git", "nopam@https://github.com/yunxing/nopam.git": version "0.0.1" resolved nopam.git-8584695c8e2615857d4f58a0dec7bae3a9059a54#49cd1b4ccc32d588cdd3a671d4cc6d773803396b @@ -1372,6 +1431,13 @@ resolve@^1.1.7: opam-installer-bin "https://github.com/yunxing/opam-installer-bin.git" substs "https://github.com/yunxing/substs.git" +yarn-pkg-config@*: + version "0.29.3" + resolved yarn-pkg-config-0.29.3.tgz#d71f04aabc743be557d5f2fa80e9e13049723107 + dependencies: + dependency-env "https://github.com/npm-ml/dependency-env.git" + nopam "https://github.com/yunxing/nopam.git" + "yojson-actual@git://github.com/npm-opam/yojson.git#1.3.2": version "1.3.2" resolved yojson.git-dd81adbf47ff9d54f7614716c26bc97dffb7bcb1#6e4b7241179fbb7512bf15a82bd2731f195db48b