From: Richard W.M. Jones <"Richard W.M. Jones "> Date: Tue, 3 Jun 2008 09:11:40 +0000 (+0100) Subject: Import from CVS. X-Git-Url: http://git.annexia.org/?p=virt-mem.git;a=commitdiff_plain;h=40940dbca159a90c43b46297011246256c5da30e Import from CVS. --- 40940dbca159a90c43b46297011246256c5da30e diff --git a/.depend b/.depend new file mode 100644 index 0000000..5f4eb15 --- /dev/null +++ b/.depend @@ -0,0 +1,5 @@ +virt_mem_mmap.cmi: virt_mem_utils.cmo +virt_mem.cmo: virt_mem_utils.cmo virt_mem_mmap.cmi +virt_mem.cmx: virt_mem_utils.cmx virt_mem_mmap.cmx +virt_mem_mmap.cmo: virt_mem_utils.cmo virt_mem_mmap.cmi +virt_mem_mmap.cmx: virt_mem_utils.cmx virt_mem_mmap.cmi diff --git a/.hgignore b/.hgignore new file mode 100644 index 0000000..6cf3a58 --- /dev/null +++ b/.hgignore @@ -0,0 +1,17 @@ +syntax:glob +Makefile +*~ +*.opt +*.annot +*.cmi +*.cmo +*.cmx +autom4te.cache +config.h +config.h.in +config.log +config.status +configure +gmon.out +virt-mem +virt_mem_gettext.ml diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 0000000..df5123b --- /dev/null +++ b/Makefile.in @@ -0,0 +1,129 @@ +# virt-mem +# @configure_input@ +# Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public +# License as published by the Free Software Foundation; either +# version 2 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +PACKAGE = @PACKAGE_NAME@ +VERSION = @PACKAGE_VERSION@ + +INSTALL = @INSTALL@ + +SYNTAX = -pp "camlp4o -I`ocamlc -where`/bitmatch bitmatch.cma pa_bitmatch.cmo" + +#OCAMLCPACKAGES = -package unix,bigarray,extlib,bitmatch +OCAMLCPACKAGES = -package unix,bigarray,extlib -I +bitmatch + +ifneq ($(pkg_gettext),no) +OCAMLCPACKAGES += -package gettext-stub +endif + +OCAMLCFLAGS = @OCAMLCFLAGS@ $(SYNTAX) +OCAMLCLIBS = -linkpkg bitmatch.cma + +OCAMLOPTFLAGS = @OCAMLOPTFLAGS@ $(SYNTAX) +OCAMLOPTPACKAGES = $(OCAMLCPACKAGES) +OCAMLOPTLIBS = -linkpkg bitmatch.cmxa + +OCAMLDOCFLAGS = -html -stars -sort $(OCAMLCPACKAGES) $(SYNTAX) + +TARGETS = virt-mem virt-mem.opt + +OBJS = virt_mem_gettext.cmo \ + virt_mem_utils.cmo \ + virt_mem_mmap.cmo \ + virt_mem.cmo +XOBJS = virt_mem_gettext.cmx \ + virt_mem_utils.cmx \ + virt_mem_mmap.cmx \ + virt_mem.cmx + +all: $(TARGETS) + +virt-mem: $(OBJS) + ocamlfind ocamlc \ + $(OCAMLCFLAGS) $(OCAMLCPACKAGES) $(OCAMLCLIBS) $^ -o $@ + +virt-mem.opt: $(XOBJS) + ocamlfind ocamlopt \ + $(OCAMLOPTFLAGS) $(OCAMLOPTPACKAGES) $(OCAMLOPTLIBS) $^ -o $@ + +# Common rules for building OCaml objects. + +.mli.cmi: + ocamlfind ocamlc $(OCAMLCFLAGS) $(OCAMLCPACKAGES) -c $< +.ml.cmo: + ocamlfind ocamlc $(OCAMLCFLAGS) $(OCAMLCPACKAGES) -c $< +.ml.cmx: + ocamlfind ocamlopt $(OCAMLOPTFLAGS) $(OCAMLOPTPACKAGES) -c $< + +clean: + rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a \ + *.so *.opt *~ *.dll *.exe *.annot core + +# Distribution. + +dist: + $(MAKE) check-manifest + rm -rf $(PACKAGE)-$(VERSION) + mkdir $(PACKAGE)-$(VERSION) + tar -cf - -T MANIFEST | tar -C $(PACKAGE)-$(VERSION) -xf - + $(INSTALL) -m 0755 configure $(PACKAGE)-$(VERSION)/ + tar zcf $(PACKAGE)-$(VERSION).tar.gz $(PACKAGE)-$(VERSION) + rm -rf $(PACKAGE)-$(VERSION) + ls -l $(PACKAGE)-$(VERSION).tar.gz + +check-manifest: + @for d in `find -type d -name CVS | grep -v '^\./debian/'`; \ + do \ + b=`dirname $$d`/; \ + awk -F/ '$$1 != "D" {print $$2}' $$d/Entries | \ + sed -e "s|^|$$b|" -e "s|^\./||"; \ + done | sort > .check-manifest; \ + sort MANIFEST > .orig-manifest; \ + diff -u .orig-manifest .check-manifest; rv=$$?; \ + rm -f .orig-manifest .check-manifest; \ + exit $$rv + +#check-manifest: +# hg manifest | sort > .check-manifest; \ +# sort MANIFEST > .orig-manifest; \ +# diff -u .orig-manifest .check-manifest; rv=$$?; \ +# rm -f .orig-manifest .check-manifest; \ +# exit $$rv + +# Developer documentation (in html/ subdirectory). + +doc: + rm -rf html + mkdir html + -ocamlfind ocamldoc $(OCAMLDOCFLAGS) -d html *.{ml,mli} + +# Dependencies. + +depend: .depend + +.depend: $(wildcard *.mli) $(wildcard *.ml) + rm -f .depend + ocamldep $(SYNTAX) $^ > $@ + +ifeq ($(wildcard .depend),.depend) +include .depend +endif + +.PHONY: all opt depend install clean distclean configure dist check-manifest \ + release release_stage_2 release_stage_3 force + +.SUFFIXES: .cmo .cmi .cmx .ml .mli diff --git a/aclocal.m4 b/aclocal.m4 new file mode 100644 index 0000000..fad331a --- /dev/null +++ b/aclocal.m4 @@ -0,0 +1,185 @@ +dnl autoconf macros for OCaml +dnl by Olivier Andrieu +dnl modified by Richard W.M. Jones +dnl from a configure.in by Jean-Christophe Filliâtre, +dnl from a first script by Georges Mariano +dnl +dnl defines AC_PROG_OCAML that will check the OCaml compiler +dnl and set the following variables : +dnl OCAMLC "ocamlc" if present in the path, or a failure +dnl or "ocamlc.opt" if present with same version number as ocamlc +dnl OCAMLOPT "ocamlopt" (or "ocamlopt.opt" if present), or "no" +dnl OCAMLBEST either "byte" if no native compiler was found, +dnl or "opt" otherwise +dnl OCAMLDEP "ocamldep" +dnl OCAMLLIB the path to the ocaml standard library +dnl OCAMLVERSION the ocaml version number +AC_DEFUN(AC_PROG_OCAML, +[dnl +# checking for ocamlc +AC_CHECK_PROG(OCAMLC,ocamlc,ocamlc,AC_MSG_ERROR(Cannot find ocamlc.)) +OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' ` +AC_MSG_RESULT(OCaml version is $OCAMLVERSION) +OCAMLLIB=`$OCAMLC -where 2>/dev/null || $OCAMLC -v|tail -1|cut -d ' ' -f 4` +AC_MSG_RESULT(OCaml library path is $OCAMLLIB) +# checking for ocamlopt +AC_CHECK_PROG(OCAMLOPT,ocamlopt,ocamlopt) +OCAMLBEST=byte +if test -z "$OCAMLOPT"; then + AC_MSG_WARN(Cannot find ocamlopt; bytecode compilation only.) +else + TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' ` + if test "$TMPVERSION" != "$OCAMLVERSION" ; then + AC_MSG_RESULT(versions differs from ocamlc; ocamlopt discarded.) + unset OCAMLOPT + else + OCAMLBEST=opt + fi +fi +# checking for ocamlc.opt +AC_CHECK_PROG(OCAMLCDOTOPT,ocamlc.opt,ocamlc.opt) +if test -z "$OCAMLCDOTOPT"; then + TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' ` + if test "$TMPVERSION" != "$OCAMLVERSION" ; then + AC_MSG_RESULT(versions differs from ocamlc; ocamlc.opt discarded.) + else + OCAMLC=$OCAMLCDOTOPT + fi +fi +# checking for ocamlopt.opt +if test "$OCAMLOPT" ; then + AC_CHECK_PROG(OCAMLOPTDOTOPT,ocamlopt.opt,ocamlopt.opt) + if test "$OCAMLOPTDOTOPT"; then + TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' ` + if test "$TMPVER" != "$OCAMLVERSION" ; then + AC_MSG_RESULT(version differs from ocamlc; ocamlopt.opt discarded.) + else + OCAMLOPT=$OCAMLOPTDOTOPT + fi + fi +fi +# checking for ocamldep +AC_CHECK_PROG(OCAMLDEP,ocamldep,ocamldep,AC_MSG_ERROR(Cannot find ocamldep.)) + +#checking for ocamlmktop +AC_CHECK_PROG(OCAMLMKTOP,ocamlmktop,ocamlmktop, AC_MSG_WARN(Cannot find ocamlmktop.)) +#checking for ocamlmklib +AC_CHECK_PROG(OCAMLMKLIB,ocamlmklib,ocamlmklib, AC_MSG_WARN(Cannot find ocamlmklib.)) +# checking for ocamldoc +AC_CHECK_PROG(OCAMLDOC,ocamldoc,ocamldoc, AC_MSG_WARN(Cannot find ocamldoc.)) + + +AC_SUBST(OCAMLC) +AC_SUBST(OCAMLOPT) +AC_SUBST(OCAMLDEP) +AC_SUBST(OCAMLBEST) +AC_SUBST(OCAMLVERSION) +AC_SUBST(OCAMLLIB) +AC_SUBST(OCAMLMKLIB) +AC_SUBST(OCAMLDOC) +]) + + +dnl macro AC_PROG_OCAML_TOOLS will check OCamllex and OCamlyacc : +dnl OCAMLLEX "ocamllex" or "ocamllex.opt" if present +dnl OCAMLYACC "ocamlyac" +AC_DEFUN(AC_PROG_OCAML_TOOLS, +[dnl +# checking for ocamllex and ocamlyacc +AC_CHECK_PROG(OCAMLLEX,ocamllex,ocamllex) +if test "$OCAMLLEX"; then + AC_CHECK_PROG(OCAMLLEXDOTOPT,ocamllex.opt,ocamllex.opt) + if test "$OCAMLLEXDOTOPT"; then + OCAMLLEX=$OCAMLLEXDOTOPT + fi +else + AC_MSG_ERROR(Cannot find ocamllex.) +fi +AC_CHECK_PROG(OCAMLYACC,ocamlyacc,ocamlyacc,AC_MSG_ERROR(Cannot find ocamlyacc.)) +AC_SUBST(OCAMLLEX) +AC_SUBST(OCAMLYACC) +]) + + +dnl AC_PROG_CAMLP4 checks for Camlp4 +AC_DEFUN(AC_PROG_CAMLP4, +[dnl +AC_REQUIRE([AC_PROG_OCAML]) +# checking for camlp4 +AC_CHECK_PROG(CAMLP4,camlp4,camlp4) +if test "$CAMLP4"; then + TMPVERSION=`$CAMLP4 -v 2>&1| sed -n -e 's|.*version *\(.*\)$|\1|p'` + if test "$TMPVERSION" != "$OCAMLVERSION" ; then + AC_MSG_RESULT(versions differs from ocamlc) + fi +fi +]) + + +dnl macro AC_PROG_FINDLIB will check for the presence of +dnl ocamlfind +AC_DEFUN(AC_PROG_FINDLIB, +[dnl +# checking for ocamlfind +AC_CHECK_PROG(OCAMLFIND,ocamlfind,ocamlfind, + AC_MSG_WARN([ocamlfind not found])) +AC_SUBST(OCAMLFIND) +]) + + +dnl AC_CHECK_OCAML_PKG checks wether a findlib package is present +dnl defines pkg_name to "yes" +AC_DEFUN(AC_CHECK_OCAML_PKG, +[dnl +AC_REQUIRE([AC_PROG_FINDLIB]) +AC_MSG_CHECKING(findlib package $1) +if $OCAMLFIND query $1 >/dev/null 2>/dev/null; then +AC_MSG_RESULT(found) +eval "pkg_`echo $1 | tr - _`=yes" +else +AC_MSG_RESULT(not found) +eval "pkg_`echo $1 | tr - _`=no" +fi +]) + + +dnl AC_CHECK_OCAML_MODULE looks for a module in a given path +dnl 1st arg -> name (just for printing messages) +dnl 2nd arg -> env var name (set to include path, or "no" if not found) +dnl 3rd arg -> module to check +dnl 4th arg -> default include dirs to check +AC_DEFUN([AC_CHECK_OCAML_MODULE], +[dnl +AC_MSG_CHECKING(for module $1) +cat > conftest.ml <&5 2>&5 ; then + found=yes + break + fi +done +if test "$found" ; then + AC_MSG_RESULT($$2) +else + AC_MSG_RESULT(not found) + $2=no +fi +AC_SUBST($2)]) + + +dnl AC_CHECK_OCAML_WORD_SIZE(var) sets var=32 or var=64 +dnl according to the compiler word size. +dnl Contributed by Richard W.M. Jones +dnl XXX This completely fails to deal with cross-compiler case. +AC_DEFUN([AC_CHECK_OCAML_WORD_SIZE], +[dnl +AC_MSG_CHECKING(for OCaml compiler word size) +cat > conftest.ml < $f + if test "x$pkg_gettext" != "xno"; then + # Gettext module is available, so use it. + cat <>$f +module Gettext = Gettext.Program ( + struct + let textdomain = "$d" + let codeset = None + let dir = None + let dependencies = [[]] + end +) (GettextStub.Native) +EOT + else + # No gettext module is available, so fake the translation functions. + cat <>$f +module Gettext = struct + external s_ : string -> string = "%identity" + external f_ : ('a -> 'b, 'c, 'd) format -> ('a -> 'b, 'c, 'd) format + = "%identity" + let sn_ : string -> string -> int -> string + = fun s p n -> if n = 1 then s else p + let fn_ : ('a -> 'b, 'c, 'd) format -> ('a -> 'b, 'c, 'd) format -> int + -> ('a -> 'b, 'c, 'd) format + = fun s p n -> if n = 1 then s else p +end +EOT + fi +done + +dnl Enable type annotation files (always, there's no penalty for doing +dnl this). Use C-c C-t in emacs to print the type of an expression. +OCAMLCFLAGS="-dtypes -g" +OCAMLOPTFLAGS="" + +dnl Enable profiling support for native code. +AC_ARG_ENABLE([profiling], + [AS_HELP_STRING([--enable-profiling], + [enable profiling for native code])], + [OCAMLOPTFLAGS="$OCAMLOPTFLAGS -p"]) + +AC_SUBST(OCAMLCFLAGS) +AC_SUBST(OCAMLOPTFLAGS) + +dnl Summary. +echo "------------------------------------------------------------" +echo "Thanks for downloading" $PACKAGE_STRING +echo "------------------------------------------------------------" + +dnl Produce output files. +AC_CONFIG_HEADERS([config.h]) +AC_CONFIG_FILES([Makefile + po/Makefile + ]) +AC_OUTPUT diff --git a/install-sh b/install-sh new file mode 100755 index 0000000..4fbbae7 --- /dev/null +++ b/install-sh @@ -0,0 +1,507 @@ +#!/bin/sh +# install - install a program, script, or datafile + +scriptversion=2006-10-14.15 + +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. +# +# Copyright (C) 1994 X Consortium +# +# 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 +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# +# FSF changes to this file are in the public domain. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. + +nl=' +' +IFS=" "" $nl" + +# 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 + +# Put in absolute file names if you don't have them in your path; +# or use environment vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +posix_glob= +posix_mkdir= + +# Desired mode of installed file. +mode=0755 + +chmodcmd=$chmodprog +chowncmd= +chgrpcmd= +stripcmd= +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src= +dst= +dir_arg= +dstarg= +no_target_directory= + +usage="Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE + or: $0 [OPTION]... SRCFILES... DIRECTORY + or: $0 [OPTION]... -t DIRECTORY SRCFILES... + or: $0 [OPTION]... -d DIRECTORIES... + +In the 1st form, copy SRCFILE to DSTFILE. +In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. +In the 4th, create DIRECTORIES. + +Options: +-c (ignored) +-d create directories instead of installing files. +-g GROUP $chgrpprog installed files to GROUP. +-m MODE $chmodprog installed files to MODE. +-o USER $chownprog installed files to USER. +-s $stripprog installed files. +-t DIRECTORY install into DIRECTORY. +-T report an error if DSTFILE is a directory. +--help display this help and exit. +--version display version info and exit. + +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG +" + +while test $# -ne 0; do + case $1 in + -c) shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + --help) echo "$usage"; exit $?;; + + -m) mode=$2 + shift + shift + case $mode in + *' '* | *' '* | *' +'* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -s) stripcmd=$stripprog + shift + continue;; + + -t) dstarg=$2 + shift + shift + continue;; + + -T) no_target_directory=true + shift + continue;; + + --version) echo "$0 $scriptversion"; exit $?;; + + --) shift + break;; + + -*) echo "$0: invalid option: $1" >&2 + exit 1;; + + *) break;; + esac +done + +if test $# -ne 0 && test -z "$dir_arg$dstarg"; then + # When -d is used, all remaining arguments are directories to create. + # When -t is used, the destination is already specified. + # Otherwise, the last argument is the destination. Remove it from $@. + for arg + do + if test -n "$dstarg"; then + # $@ is not empty: it contains at least $arg. + set fnord "$@" "$dstarg" + shift # fnord + fi + shift # arg + dstarg=$arg + done +fi + +if test $# -eq 0; then + if test -z "$dir_arg"; then + echo "$0: no input file specified." >&2 + exit 1 + fi + # It's OK to call `install-sh -d' without argument. + # This can happen when creating conditional directories. + exit 0 +fi + +if test -z "$dir_arg"; then + trap '(exit $?); exit' 1 2 13 15 + + # Set umask so as not to create temps with too-generous modes. + # However, 'strip' requires both read and write access to temps. + case $mode in + # Optimize common cases. + *644) cp_umask=133;; + *755) cp_umask=22;; + + *[0-7]) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw='% 200' + fi + cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; + *) + if test -z "$stripcmd"; then + u_plus_rw= + else + u_plus_rw=,u+rw + fi + cp_umask=$mode$u_plus_rw;; + esac +fi + +for src +do + # Protect names starting with `-'. + case $src in + -*) src=./$src ;; + esac + + if test -n "$dir_arg"; then + dst=$src + dstdir=$dst + test -d "$dstdir" + dstdir_status=$? + else + + # Waiting for this to be detected by the "$cpprog $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dstarg"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + + dst=$dstarg + # Protect names starting with `-'. + case $dst in + -*) dst=./$dst ;; + esac + + # 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 + echo "$0: $dstarg: Is a directory" >&2 + exit 1 + fi + dstdir=$dst + 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' + ` + + test -d "$dstdir" + dstdir_status=$? + fi + fi + + obsolete_mkdir_used=false + + if test $dstdir_status != 0; then + case $posix_mkdir in + '') + # Create intermediate dirs using mode 755 as modified by the umask. + # This is like FreeBSD 'install' as of 1997-10-28. + umask=`umask` + case $stripcmd.$umask in + # Optimize common cases. + *[2367][2367]) mkdir_umask=$umask;; + .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; + + *[0-7]) + mkdir_umask=`expr $umask + 22 \ + - $umask % 100 % 40 + $umask % 20 \ + - $umask % 10 % 4 + $umask % 2 + `;; + *) mkdir_umask=$umask,go-w;; + esac + + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + case $umask in + *[123567][0-7][0-7]) + # POSIX mkdir -p sets u+wx bits regardless of umask, which + # is incompatible with FreeBSD 'install' when (umask & 300) != 0. + ;; + *) + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 + + if (umask $mkdir_umask && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writeable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + ls_ld_tmpdir=`ls -ld "$tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/d" "$tmpdir" + else + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null + fi + trap '' 0;; + esac;; + esac + + if + $posix_mkdir && ( + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + ) + then : + else + + # The umask is ridiculous, or mkdir does not conform to POSIX, + # or it failed possibly due to a race condition. Create the + # directory the slow way, step by step, checking for races as we go. + + case $dstdir in + /*) prefix=/ ;; + -*) prefix=./ ;; + *) prefix= ;; + esac + + case $posix_glob in + '') + if (set -f) 2>/dev/null; then + posix_glob=true + else + posix_glob=false + fi ;; + esac + + oIFS=$IFS + IFS=/ + $posix_glob && set -f + set fnord $dstdir + shift + $posix_glob && set +f + IFS=$oIFS + + prefixes= + + for d + do + test -z "$d" && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask=$mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ + done + + if test -n "$prefixes"; then + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true + fi + fi + fi + + if test -n "$dir_arg"; then + { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && + { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && + { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || + test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 + else + + # Make a couple of temp file names in the proper directory. + dsttmp=$dstdir/_inst.$$_ + rmtmp=$dstdir/_rm.$$_ + + # Trap to clean up those temp files at exit. + trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 + + # Copy the file name to the temp name. + (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $cpprog $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } \ + && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } \ + && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } \ + && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && + + # Now rename the file to the real destination. + { $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null \ + || { + # The rename failed, perhaps because mv can't rename something else + # to itself, or perhaps because mv is so ancient that it does not + # support -f. + + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + if test -f "$dst"; then + $doit $rmcmd -f "$dst" 2>/dev/null \ + || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null \ + && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }; }\ + || { + echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + else + : + fi + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" + } + } || exit 1 + + trap '' 0 + fi +done + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-end: "$" +# End: diff --git a/po/.cvsignore b/po/.cvsignore new file mode 100644 index 0000000..33ceb8f --- /dev/null +++ b/po/.cvsignore @@ -0,0 +1 @@ +Makefile \ No newline at end of file diff --git a/po/LINGUAS b/po/LINGUAS new file mode 100644 index 0000000..e69de29 diff --git a/po/Makefile.in b/po/Makefile.in new file mode 100644 index 0000000..215884c --- /dev/null +++ b/po/Makefile.in @@ -0,0 +1,79 @@ +# Makefile for po subdirectory. +# @configure_input@ +# +# Copyright (C) 2007-2008 Red Hat Inc. +# Written by Richard W.M. Jones +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +OCAML_GETTEXT_PACKAGE = virt-df +LINGUAS = $(shell cat LINGUAS) +SOURCES = POTFILES + +OCAML_GETTEXT = @OCAML_GETTEXT@ +OCAML_GETTEXT_EXTRACT_OPTIONS = +OCAML_GETTEXT_COMPILE_OPTIONS = +OCAML_GETTEXT_INSTALL_OPTIONS = +OCAML_GETTEXT_MERGE_OPTIONS = + +PODIR = @prefix@/share/locale + +POFILES = $(addsuffix .po,$(LINGUAS)) +MOFILES = $(addsuffix .mo,$(LINGUAS)) +POTFILE = $(OCAML_GETTEXT_PACKAGE).pot + +all: $(MOFILES) $(POTFILE) + +install: install-po + +uninstall: uninstall-po + +clean:: clean-po + +%.mo: %.po + $(OCAML_GETTEXT) --action compile $(OCAML_GETTEXT_COMPILE_OPTIONS) \ + --compile-output $@ $^ + +%.pot: $(SOURCES) $(shell cat $(SOURCES)) + $(OCAML_GETTEXT) --action extract $(OCAML_GETTEXT_EXTRACT_OPTIONS) \ + --extract-pot $@ $< + +# Also includes a fix for incorrectly escaped multi-byte sequences. +%.po: $(POTFILE) + $(OCAML_GETTEXT) --action merge $(OCAML_GETTEXT_MERGE_OPTIONS) \ + --merge-pot $(POTFILE) $@ + mv $@ $@.orig + perl -wpe 's/\\(\d{3})/pack "C*", $$1/ge' < $@.orig > $@ + +$(BUILDPO): + mkdir -p $(BUILDPO) + +.PRECIOUS: $(POTFILE) + +install-po: $(MOFILES) + $(OCAML_GETTEXT) --action install $(OCAML_GETTEXT_INSTALL_OPTIONS) \ + --install-textdomain $(OCAML_GETTEXT_PACKAGE) \ + --install-destdir $(PODIR) $(MOFILES) + +uninstall-po: + $(OCAML_GETTEXT) --action uninstall $(OCAML_GETTEXT_INSTALL_OPTIONS) \ + --uninstall-textdomain $(OCAML_GETTEXT_PACKAGE) \ + --uninstall-orgdir $(PODIR) $(MOFILES) + +clean-po: + -$(OCAML_GETTEXT) --action uninstall $(OCAML_GETTEXT_INSTALL_OPTIONS) \ + --uninstall-textdomain $(OCAML_GETTEXT_PACKAGE) \ + --uninstall-orgdir $(BUILDPO) $(MOFILES) + -$(RM) $(MOFILES) diff --git a/po/POTFILES b/po/POTFILES new file mode 100644 index 0000000..199332d --- /dev/null +++ b/po/POTFILES @@ -0,0 +1,3 @@ +virt_mem.ml +virt_mem_mmap.ml +virt_mem_utils.ml \ No newline at end of file diff --git a/po/virt-mem.pot b/po/virt-mem.pot new file mode 100644 index 0000000..4b42260 --- /dev/null +++ b/po/virt-mem.pot @@ -0,0 +1,167 @@ +# SOME DESCRIPTIVE TITLE. +# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# FIRST AUTHOR , YEAR. +# +#, fuzzy +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2008-04-28 12:49+0000\n" +"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=CHARSET\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=INTEGER; plural=EXPRESSION;\n" + +#: ../virt-df/virt_df_main.ml:83 +msgid "%s: unknown parameter" +msgstr "" + +#: ../virt-df/virt_df_main.ml:77 +msgid "(Test mode) Display contents of block device or file" +msgstr "" + +#: ../virt-df/virt_df_main.ml:268 +msgid "1K-blocks" +msgstr "" + +#: ../virt-df/virt_df_main.ml:269 ../virt-df/virt_df_main.ml:268 +msgid "Available" +msgstr "" + +#: ../virt-df/virt_df_main.ml:100 +msgid "CSV is not supported in this build of virt-df" +msgstr "" + +#: ../virt-df/virt_df_main.ml:63 ../virt-df/virt_df_main.ml:61 +msgid "Connect to URI (default: Xen)" +msgstr "" + +#: ../virt-df/virt_df_main.ml:67 ../diskzip/diskzip.ml:83 +msgid "Debug mode (default: false)" +msgstr "" + +#: ../virt-df/virt_df_main.ml:79 ../diskzip/diskzip.ml:93 +msgid "Display version and exit" +msgstr "" + +#: ../virt-df/virt_df_main.ml:273 +msgid "Filesystem" +msgstr "" + +#: ../diskzip/diskzip.ml:85 +msgid "Force compress even if stdout looks like a tty" +msgstr "" + +#: ../virt-df/virt_df_main.ml:270 +msgid "IFree" +msgstr "" + +#: ../virt-df/virt_df_main.ml:270 +msgid "IUse" +msgstr "" + +#: ../virt-df/virt_df_main.ml:270 +msgid "Inodes" +msgstr "" + +#: ../virt-df/virt_df_main.ml:119 +msgid "NB: If you want to monitor a local Xen hypervisor, you usually need to be root" +msgstr "" + +#: ../diskzip/diskzip.ml:87 +msgid "Pipe the output/input through bzip2" +msgstr "" + +#: ../diskzip/diskzip.ml:91 +msgid "Pipe the output/input through external program" +msgstr "" + +#: ../diskzip/diskzip.ml:95 +msgid "Pipe the output/input through gzip" +msgstr "" + +#: ../virt-df/virt_df_main.ml:71 ../virt-df/virt_df_main.ml:69 +msgid "Print sizes in human-readable format" +msgstr "" + +#: ../diskzip/diskzip.ml:89 +msgid "Set the output filename or directory name" +msgstr "" + +#: ../virt-df/virt_df_main.ml:59 ../virt-df/virt_df_main.ml:57 +msgid "Show all domains (default: only active domains)" +msgstr "" + +#: ../virt-df/virt_df_main.ml:75 ../virt-df/virt_df_main.ml:73 +msgid "Show inodes instead of blocks" +msgstr "" + +#: ../virt-df/virt_df_main.ml:269 +msgid "Size" +msgstr "" + +#: ../virt-df/virt_df_main.ml:273 +msgid "Type" +msgstr "" + +#: ../diskzip/diskzip.ml:81 +msgid "Uncompress (default: depends on executable name)" +msgstr "" + +#: ../virt-df/virt_df_main.ml:269 ../virt-df/virt_df_main.ml:268 +msgid "Used" +msgstr "" + +#: ../virt-df/virt_df_main.ml:65 +msgid "Write results in CSV format" +msgstr "" + +#: ../diskzip/diskzip.ml:53 +msgid "diskzip: '-o' option cannot appear more than once" +msgstr "" + +#: ../diskzip/diskzip.ml:119 +msgid "diskzip: '-o' option cannot be used when compressing" +msgstr "" + +#: ../diskzip/diskzip.ml:71 +msgid "diskzip: '-z' or '-j' cannot appear more than once" +msgstr "" + +#: ../diskzip/diskzip.ml:100 +msgid "diskzip: Intelligently compress disk images\n\nSUMMARY\n diskzip [-options] disk.img [disk.img ...] > output.dz\n diskzcat [-options] output.dz > disk.img\n\nOPTIONS" +msgstr "" + +#: ../diskzip/diskzip.ml:127 +msgid "diskzip: compressed data not written to a terminal, use '-f' to force" +msgstr "" + +#: ../diskzip/diskzip.ml:123 +msgid "diskzip: no input" +msgstr "" + +#: ../diskzip/diskzip.ml:40 +msgid "diskzip: unknown executable name '%s', assuming 'diskzip'\\n" +msgstr "" + +#: ../virt-df/virt_df_main.ml:158 +msgid "get_xml_desc didn't return " +msgstr "" + +#: ../virt-df/virt_df_main.ml:166 +msgid "get_xml_desc returned no node in XML" +msgstr "" + +#: ../virt-df/virt_df_main.ml:169 +msgid "get_xml_desc returned strange node" +msgstr "" + +#: ../virt-df/virt_df_main.ml:84 +msgid "virt-df : like 'df', shows disk space used in guests\n\nSUMMARY\n virt-df [-options]\n\nOPTIONS" +msgstr "" + diff --git a/virt_mem.ml b/virt_mem.ml new file mode 100644 index 0000000..82e0b37 --- /dev/null +++ b/virt_mem.ml @@ -0,0 +1,312 @@ +(* Memory info command for virtual domains. + (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + *) + +open Unix +open Printf +open ExtList + +open Virt_mem_utils +module MMap = Virt_mem_mmap + +(* Main program. *) +let () = + (* Verbose messages. *) + let verbose = ref false in + + (* Default wordsize. *) + let def_wordsize = ref None in + let set_wordsize = function + | "32" -> def_wordsize := Some W32 + | "64" -> def_wordsize := Some W64 + | "auto" -> def_wordsize := None + | str -> failwith (sprintf "set_wordsize: %s: unknown wordsize" str) + in + + (* Default endianness. *) + let def_endian = ref None in + let set_endian = function + | "auto" -> def_endian := None + | "le" | "little" | "littleendian" | "intel" -> + def_endian := Some Bitmatch.LittleEndian + | "be" | "big" | "bigendian" | "motorola" -> + def_endian := Some Bitmatch.BigEndian + | str -> failwith (sprintf "set_endian: %s: unknown endianness" str) + in + + (* Default architecture. *) + let def_architecture = ref None in + let set_architecture = function + | "auto" -> def_architecture := None + | arch -> + let arch = architecture_of_string arch in + def_architecture := Some arch; + def_endian := Some (endian_of_architecture arch); + def_wordsize := Some (wordsize_of_architecture arch) + in + + (* Default text address. *) + let def_text_addr = ref 0L (* 0 = auto-detect *) in + let set_text_addr = function + | "auto" -> def_text_addr := 0L + | "i386" -> def_text_addr := 0xc010_0000_L (* common for x86 *) + | "x86-64"|"x86_64" -> def_text_addr := 0xffffffff_81000000_L (* x86-64? *) + | str -> def_text_addr := Int64.of_string str + in + + (* List of kernel images. *) + let images = ref [] in + + let memory_image filename = + images := + (!def_wordsize, !def_endian, !def_architecture, !def_text_addr, filename) + :: !images + in + + let argspec = Arg.align [ + "-A", Arg.String set_architecture, + "arch " ^ "Set kernel architecture, endianness and word size"; + "-E", Arg.String set_endian, + "endian " ^ "Set kernel endianness"; + "-T", Arg.String set_text_addr, + "addr " ^ "Set kernel text address"; + "-W", Arg.String set_wordsize, + "addr " ^ "Set kernel word size"; + "-t", Arg.String memory_image, + "image " ^ "Use saved kernel memory image"; + "-verbose", Arg.Set verbose, + " " ^ "Verbose messages"; + ] in + + let anon_fun str = + raise (Arg.Bad (sprintf "%s: unknown parameter" str)) in + let usage_msg = "virt-mem: shows memory information for guests + +SUMMARY + virt-mem [-options] + +OPTIONS" in + + Arg.parse argspec anon_fun usage_msg; + + let images = !images in + let verbose = !verbose in + + (* Get the kernel images. *) + let images = + if images = [] then + (* XXX use libvirt to get images *) + failwith "libvirt: not yet implemented" + else + List.map ( + fun (wordsize, endian, arch, text_addr, filename) -> + (* Quite a lot of limitations on the kernel images we can + * handle at the moment ... + *) + (* XXX We could auto-detect wordsize easily. *) + let wordsize = + match wordsize with + | None -> + failwith + (sprintf "%s: use -W to define word size for this image" + filename); + | Some ws -> ws in + let endian = + match endian with + | None -> + failwith + (sprintf "%s: use -E to define endianness for this image" + filename); + | Some e -> e in + + let arch = + match arch with + | Some I386 -> I386 | Some X86_64 -> X86_64 + | _ -> + failwith + (sprintf "%s: use -A to define architecture (i386/x86-64 only) for this image" filename) in + + if text_addr = 0L then + failwith + (sprintf "%s: use -T to define kernel load address for this image" + filename); + + (* Map the virtual memory. *) + let fd = openfile filename [O_RDONLY] 0 in + let mem = MMap.of_file fd text_addr in + + (* Force the wordsize and endianness. *) + let mem = MMap.set_wordsize mem wordsize in + let mem = MMap.set_endian mem endian in + + (filename, (arch, mem)) + ) images in + + List.iter ( + fun (name, (arch, mem)) -> + (* Look for some common entries in the symbol table and from + * that find the symbol table itself. These are just supposed to + * be symbols which are very likely to be present in any Linux + * kernel, although we only need one of them to be present to + * find the symbol table. + * + * NB. Must not be __initdata. + *) + let common_ksyms = [ + "init_task"; (* first task_struct *) + "root_mountflags"; (* flags for mounting root fs *) + "init_uts_ns"; (* uname strings *) + "sys_open"; (* open(2) entry point *) + "sys_chdir"; (* chdir(2) entry point *) + "sys_chroot"; (* chroot(2) entry point *) + "sys_umask"; (* umask(2) entry point *) + "schedule"; (* scheduler entry point *) + ] in + (* Searching for string *) + let common_ksyms = List.map (sprintf "\000%s\000") common_ksyms in + + (* Search for these strings in the memory image. *) + let ksym_strings = List.map (MMap.find_all mem) common_ksyms in + let ksym_strings = List.concat ksym_strings in + (* Adjust found addresses to start of the string (skip ). *) + let ksym_strings = List.map Int64.succ ksym_strings in + + (* For any we found, try to look up the symbol table + * base addr and size. + *) + let ksymtabs = List.map ( + fun addr -> + (* Search for 'addr' appearing in the image. *) + let addrs = MMap.find_pointer_all mem addr in + + (* Now consider each of these addresses and search back + * until we reach the beginning of the (possible) symbol + * table. + * + * Kernel symbol table struct is: + * struct kernel_symbol { + * unsigned long value; + * const char *name; <-- initial pointer + * } symbols[]; + *) + let pred_long2 addr = MMap.pred_long mem (MMap.pred_long mem addr) in + let base_addrs = List.map ( + fun addr -> + let rec loop addr = + (* '*addr' should point to a C identifier. If it does, + * step backwards to the previous symbol table entry. + *) + let addrp = MMap.follow_pointer mem addr in + if MMap.is_C_identifier mem addrp then + loop (pred_long2 addr) + else + MMap.succ_long mem addr + in + loop addr + ) addrs in + + (* Also look for the end of the symbol table and + * calculate its size. + *) + let base_addrs_sizes = List.map ( + fun base_addr -> + let rec loop addr = + let addr2 = MMap.succ_long mem addr in + let addr2p = MMap.follow_pointer mem addr2 in + if MMap.is_C_identifier mem addr2p then + loop (MMap.succ_long mem addr2) + else + addr + in + let end_addr = loop base_addr in + base_addr, end_addr -^ base_addr + ) base_addrs in + + base_addrs_sizes + ) ksym_strings in + let ksymtabs = List.concat ksymtabs in + + (* Simply ignore any symbol table candidates which are too small. *) + let ksymtabs = List.filter (fun (_, size) -> size > 64L) ksymtabs in + + if verbose then ( + printf "name %s:\n" name; + List.iter ( + fun (addr, size) -> + printf "\t%Lx\t%Lx\t%!" addr size; + printf "first symbol: %s\n%!" + (MMap.get_string mem + (MMap.follow_pointer mem + (MMap.succ_long mem addr))) + ) ksymtabs + ); + + (* Vote for the most popular symbol table candidate. *) + let freqs = frequency ksymtabs in + match freqs with + | [] -> + eprintf "%s: cannot find start of kernel symbol table\n" name + | (_, (ksymtab_addr, ksymtab_size)) :: _ -> + if verbose then + printf "%s: Kernel symbol table found at %Lx, size %Lx bytes\n%!" + name ksymtab_addr ksymtab_size; + + (* Load the whole symbol table as a bitstring. *) + let ksymtab = + Bitmatch.bitstring_of_string + (MMap.get_bytes mem ksymtab_addr (Int64.to_int ksymtab_size)) in + + (* Function to look up an address in the symbol table. *) + let lookup_ksym sym = + let bits = bits_of_wordsize (MMap.get_wordsize mem) in + let e = MMap.get_endian mem in + let rec loop bs = + bitmatch bs with + | { value : bits : endian(e); + name_ptr : bits : endian(e) } + when MMap.get_string mem name_ptr = sym -> + value + | { _ : bits : endian(e); + _ : bits : endian(e); + bs : -1 : bitstring } -> + loop bs + | { _ } -> raise Not_found + in + loop ksymtab + in + + if verbose then ( + (* This just tests looking up kernel symbols. *) + printf "init_task = %Lx\n" (lookup_ksym "init_task"); + printf "schedule = %Lx\n" (lookup_ksym "schedule"); + printf "system_utsname = %s\n" + (try + let addr = lookup_ksym "system_utsname" in + sprintf "%Lx" addr + with Not_found -> "not found"); + printf "init_uts_ns = %s\n" + (try + let addr = lookup_ksym "init_uts_ns" in + sprintf "%Lx" addr + with Not_found -> "not found"); + ); + + + + + ) images diff --git a/virt_mem_mmap.ml b/virt_mem_mmap.ml new file mode 100644 index 0000000..7401e17 --- /dev/null +++ b/virt_mem_mmap.ml @@ -0,0 +1,322 @@ +(* Memory info command for virtual domains. + (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + Functions for making a memory map of a virtual machine from + various sources. The memory map will most certainly have holes. + *) + +open Unix +open Bigarray + +open Virt_mem_utils + +(* Simple implementation at the moment: Store a list of mappings, + * sorted by start address. We assume that mappings do not overlap. + * We can change the implementation later if we need to. In most cases + * there will only be a small number of mappings (probably 1). + *) +type ('a,'b) t = { + mappings : mapping list; + wordsize : wordsize option; + endian : Bitmatch.endian option; +} +and mapping = { + start : addr; + size : addr; + (* Bigarray mmap(2)'d region with byte addressing: *) + arr : (char,int8_unsigned_elt,c_layout) Array1.t; +} + +and addr = int64 + +let create () = { + mappings = []; + wordsize = None; + endian = None +} + +let set_wordsize t ws = { t with wordsize = Some ws } + +let set_endian t e = { t with endian = Some e } + +let get_wordsize t = Option.get t.wordsize + +let get_endian t = Option.get t.endian + +let sort_mappings mappings = + let cmp { start = s1 } { start = s2 } = compare s1 s2 in + List.sort cmp mappings + +let add_file ({ mappings = mappings } as t) fd addr = + if addr &^ 7L <> 0L then + invalid_arg "add_file: mapping address must be aligned to 8 bytes"; + let size = (fstat fd).st_size in + (* mmap(2) the file using Bigarray module. *) + let arr = Array1.map_file fd char c_layout false size in + (* Create the mapping entry and keep the mappings sorted by start addr. *) + let mappings = + { start = addr; size = Int64.of_int size; arr = arr } :: mappings in + let mappings = sort_mappings mappings in + { t with mappings = mappings } + +let of_file fd addr = + let t = create () in + add_file t fd addr + +(* Find in mappings and return first predicate match. *) +let _find_map { mappings = mappings } pred = + let rec loop = function + | [] -> None + | m :: ms -> + match pred m with + | Some n -> Some n + | None -> loop ms + in + loop mappings + +(* Array+offset = string? *) +let string_at arr offset str strlen = + let j = ref offset in + let rec loop i = + if i >= strlen then true + else + if Array1.get arr !j <> str.[i] then false + else ( + incr j; + loop (i+1) + ) + in + loop 0 + +(* Find in a single file mapping. + * [start] is relative to the mapping and we return an offset relative + * to the mapping. + *) +let _find_in start align str arr = + let strlen = String.length str in + if strlen > 0 then ( + let j = ref start in + let e = Array1.dim arr - strlen in + let rec loop () = + if !j <= e then ( + if string_at arr !j str strlen then Some !j + else ( + j := !j + align; + loop () + ) + ) + else None + in + loop () + ) + else Some start + +(* Generic find function. *) +let _find t start align str = + _find_map t ( + fun { start = mstart; size = msize; arr = arr } -> + if mstart >= start then ( + (* Check this mapping from the beginning. *) + match _find_in 0 align str arr with + | Some offset -> Some (mstart +^ Int64.of_int offset) + | None -> None + ) + else if mstart < start && start <= mstart+^msize then ( + (* Check this mapping from somewhere in the middle. *) + let offset = Int64.to_int (start -^ mstart) in + match _find_in offset align str arr with + | Some offset -> Some (mstart +^ Int64.of_int offset) + | None -> None + ) + else None + ) + +let find t ?(start=0L) str = + _find t start 1 str + +let find_align t ?(start=0L) str = + let align = bytes_of_wordsize (get_wordsize t) in + _find t start align str + +let rec _find_all t start align str = + match _find t start align str with + | None -> [] + | Some offset -> + offset :: _find_all t (offset +^ Int64.of_int align) align str + +let find_all t ?(start=0L) str = + _find_all t start 1 str + +let find_all_align t ?(start=0L) str = + let align = bytes_of_wordsize (get_wordsize t) in + _find_all t start align str + +(* NB: Phantom types in the interface ensure that these pointer functions + * can only be called once endianness and wordsize have both been set. + *) + +let rec find_pointer t ?start addr = + find_align t ?start (string_of_addr t addr) + +and find_pointer_all t ?start addr = + find_all_align t ?start (string_of_addr t addr) + +(* +and string_of_addr t addr = + let bits = bits_of_wordsize (get_wordsize t) in + let e = get_endian t in + let bs = BITSTRING { addr : bits : endian (e) } in + Bitmatch.string_of_bitstring bs +*) +(* XXX bitmatch is missing 'construct_int64_le_unsigned' so we + * have to force this to 32 bits for the moment. + *) +and string_of_addr t addr = + let bits = bits_of_wordsize (get_wordsize t) in + assert (bits = 32); + let e = get_endian t in + let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in + Bitmatch.string_of_bitstring bs + +and addr_of_string t str = + let bits = bits_of_wordsize (get_wordsize t) in + let e = get_endian t in + let bs = Bitmatch.bitstring_of_string str in + bitmatch bs with + | { addr : bits : endian (e) } -> addr + | { _ } -> invalid_arg "addr_of_string" + +let get_byte { mappings = mappings } addr = + let rec loop = function + | [] -> invalid_arg "get_byte" + | { start = start; size = size; arr = arr } :: _ + when start <= addr && addr < size -> + let offset = Int64.to_int (addr -^ start) in + Char.code (Array1.get arr offset) + | _ :: ms -> loop ms + in + loop mappings + +(* Take bytes until a condition is not met. This is efficient in that + * we stay within the same mapping as long as we can. + *) +let dowhile { mappings = mappings } addr cond = + let rec get_next_mapping addr = function + | [] -> invalid_arg "dowhile" + | { start = start; size = size; arr = arr } :: _ + when start <= addr && addr < start +^ size -> + let offset = Int64.to_int (addr -^ start) in + let len = Int64.to_int size - offset in + arr, offset, len + | _ :: ms -> get_next_mapping addr ms + in + let rec loop addr = + let arr, offset, len = get_next_mapping addr mappings in + let rec loop2 i = + if i < len then ( + let c = Array1.get arr (offset+i) in + if cond c then loop2 (i+1) + ) else + loop (addr +^ Int64.of_int len) + in + loop2 0 + in + loop addr + +let get_bytes t addr len = + let str = String.create len in + let i = ref 0 in + try + dowhile t addr ( + fun c -> + str.[!i] <- c; + incr i; + !i < len + ); + str + with + Invalid_argument _ -> invalid_arg "get_bytes" + +let get_string t addr = + let chars = ref [] in + try + dowhile t addr ( + fun c -> + if c <> '\000' then ( + chars := c :: !chars; + true + ) else false + ); + let chars = List.rev !chars in + let len = List.length chars in + let str = String.create len in + let i = ref 0 in + List.iter (fun c -> str.[!i] <- c; incr i) chars; + str + with + Invalid_argument _ -> invalid_arg "get_string" + +let is_string t addr = + try dowhile t addr (fun c -> c <> '\000'); true + with Invalid_argument _ -> false + +let is_C_identifier t addr = + let i = ref 0 in + let r = ref true in + try + dowhile t addr ( + fun c -> + let b = + if !i = 0 then ( + c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' + ) else ( + if c = '\000' then false + else ( + if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' || + c >= '0' && c <= '9' then + true + else ( + r := false; + false + ) + ) + ) in + incr i; + b + ); + !r + with + Invalid_argument _ -> false + +let follow_pointer t addr = + let ws = get_wordsize t in + let e = get_endian t in + let bits = bits_of_wordsize ws in + let str = get_bytes t addr (bytes_of_wordsize ws) in + let bs = Bitmatch.bitstring_of_string str in + bitmatch bs with + | { addr : bits : endian (e) } -> addr + | { _ } -> invalid_arg "follow_pointer" + +let succ_long t addr = + let ws = get_wordsize t in + addr +^ Int64.of_int (bytes_of_wordsize ws) + +let pred_long t addr = + let ws = get_wordsize t in + addr -^ Int64.of_int (bytes_of_wordsize ws) diff --git a/virt_mem_mmap.mli b/virt_mem_mmap.mli new file mode 100644 index 0000000..06de86a --- /dev/null +++ b/virt_mem_mmap.mli @@ -0,0 +1,116 @@ +(* Memory info command for virtual domains. + (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + Functions for making a memory map of a virtual machine from + various sources. The memory map will most certainly have holes. + *) + +type ('a,'b) t +(** Memory map. *) + +type addr = int64 +(** Virtual memory addresses (even on 32 bit machines). *) + +val create : unit -> ([`NoWordsize], [`NoEndian]) t +(** Create a new, empty memory map. *) + +val set_wordsize : ([`NoWordsize], 'b) t -> Virt_mem_utils.wordsize -> + ([`Wordsize], 'b) t +(** Set the natural wordsize of the memory map. This is used + for matching pointers within the map and can be set only once. *) + +val set_endian : ('a, [`NoEndian]) t -> Bitmatch.endian -> + ('a, [`Endian]) t +(** Set the natural endianness of the memory map. This is used + for matching pointers within the map and can be set only once. *) + +val get_wordsize : ([`Wordsize], 'b) t -> Virt_mem_utils.wordsize +(** Return the wordsize previously set for this memory map. *) + +val get_endian : ('a, [`Endian]) t -> Bitmatch.endian +(** Return the endianness previously set for this memory map. *) + +val of_file : Unix.file_descr -> addr -> ([`NoWordsize], [`NoEndian]) t +(** Create a new memory map, mapping file [fd] at address [addr]. *) + +val add_file : ('a, 'b) t -> Unix.file_descr -> addr -> ('a, 'b) t +(** Add file [fd] at address [addr] to an existing memory map. + Behaviour is undefined if memory mappings overlap. *) + +val find : ('a, 'b) t -> ?start:addr -> string -> addr option +(** Find string in a memory map and return its address (if found). + You can pass an optional starting address. Any holes in + the memory map are skipped automatically. *) + +val find_align : ([`Wordsize], 'b) t -> ?start:addr -> string -> addr option +(** Find a string aligned to the wordsize in the memory map. *) + +val find_all : ('a, 'b) t -> ?start:addr -> string -> addr list +(** Find all occurrences of a string in a memory map. *) + +val find_all_align : ([`Wordsize], 'b) t -> ?start:addr -> string -> addr list +(** Find all occurrences of a string in a memory map. *) + +val find_pointer : ([`Wordsize], [`Endian]) t -> ?start:addr -> addr -> + addr option +(** Find a pointer (address) in the memory map. + The pointer must be aligned to a word. *) + +val find_pointer_all : ([`Wordsize], [`Endian]) t -> ?start:addr -> addr -> + addr list +(** Find all occurrences of a pointer in the memory map. *) + +val get_byte : ('a, 'b) t -> addr -> int +(** Return the byte at the given address. + + This may raise [Invalid_argument "get_byte"] if the address is + not mapped. *) + +val get_bytes : ('a, 'b) t -> addr -> int -> string +(** Return the sequence of bytes starting at the given address. + + This may raise [Invalid_argument "get_bytes"] if the address range + is not fully mapped. *) + +val get_string : ('a, 'b) t -> addr -> string +(** Return the sequence of bytes starting at [addr] up to (but not + including) the first ASCII NUL character. In other words, this + returns a C-style string. + + This may raise [Invalid_argument "get_string"] if we reach an + unmapped address before finding the end of the string. + + See also {!is_string} and {!is_C_identifier}. *) + +val is_string : ('a, 'b) t -> addr -> bool +(** Return true or false if the address contains an ASCII NUL-terminated + string. *) + +val is_C_identifier : ('a, 'b) t -> addr -> bool +(** Return true or false if the address contains a NUL-terminated + C identifier. *) + +val follow_pointer : ([`Wordsize], [`Endian]) t -> addr -> addr +(** Follow (dereference) the pointer at [addr] and return + the address pointed to. *) + +val succ_long : ([`Wordsize], 'b) t -> addr -> addr +(** Add wordsize bytes to [addr] and return it. *) + +val pred_long : ([`Wordsize], 'b) t -> addr -> addr +(** Subtract wordsize bytes from [addr] and return it. *) diff --git a/virt_mem_utils.ml b/virt_mem_utils.ml new file mode 100644 index 0000000..db759dd --- /dev/null +++ b/virt_mem_utils.ml @@ -0,0 +1,97 @@ +(* Memory info command for virtual domains. + (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + Common & utility functions. + *) + +open Printf + +let ( +^ ) = Int64.add +let ( -^ ) = Int64.sub +let ( *^ ) = Int64.mul +let ( /^ ) = Int64.div +let ( &^ ) = Int64.logand +let ( |^ ) = Int64.logor + +type architecture = + | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64 + +let string_of_architecture = function + | I386 -> "i386" + | X86_64 -> "x86_64" + | IA64 -> "ia64" + | PPC -> "ppc" + | PPC64 -> "ppc64" + | SPARC -> "sparc" + | SPARC64 -> "sparc64" + +let architecture_of_string = function + | str when + String.length str = 4 && + (str.[0] = 'i' || str.[0] = 'I') && + (str.[1] >= '3' && str.[1] <= '6') && + str.[2] = '8' && str.[3] = '6' -> I386 + | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64 + | "ia64" | "IA64" -> IA64 + | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC + | "ppc64" | "PPC64" -> PPC64 + | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC + | "sparc64" | "SPARC64" -> SPARC64 + | str -> + failwith (sprintf "architecture_of_string: %s: unknown architecture" + str) + +let endian_of_architecture = function + | I386 | X86_64 -> Bitmatch.LittleEndian + | IA64 -> Bitmatch.LittleEndian (* XXX usually? *) + | PPC | PPC64 | SPARC | SPARC64 -> Bitmatch.BigEndian + +type wordsize = + | W32 | W64 + +let wordsize_of_architecture = function + | I386 -> W32 + | X86_64 -> W64 + | IA64 -> W64 + | PPC -> W32 + | PPC64 -> W64 + | SPARC -> W32 + | SPARC64 -> W64 + +let bits_of_wordsize = function + | W32 -> 32 | W64 -> 64 +let bytes_of_wordsize = function + | W32 -> 4 | W64 -> 8 + +(* Returns (count, value) in order of highest frequency occurring in the + * list. + *) +let frequency xs = + let xs = List.sort compare xs in + let rec loop = function + | [] -> [] + | [x] -> [1, x] + | x :: y :: xs when x = y -> + let rest = loop (y :: xs) in + let (count, _), rest = List.hd rest, List.tl rest in + (count+1, y) :: rest + | x :: xs -> + (1, x) :: loop xs + in + let xs = loop xs in + List.rev (List.sort compare xs)