[Pkg-ocaml-maint-commits] r2336 - in trunk/projects: . backport
Stefano Zacchiroli
zack at costa.debian.org
Tue Dec 27 22:53:29 UTC 2005
Author: zack
Date: 2005-12-27 22:53:29 +0000 (Tue, 27 Dec 2005)
New Revision: 2336
Added:
trunk/projects/backport/
trunk/projects/backport/.depend
trunk/projects/backport/Makefile
trunk/projects/backport/backport.ml
trunk/projects/backport/bpo_version.ml
trunk/projects/backport/deblib_Files.ml
trunk/projects/backport/deblib_Files.mli
trunk/projects/backport/deblib_Get.ml
trunk/projects/backport/deblib_Get.mli
Log:
first import
Added: trunk/projects/backport/.depend
===================================================================
--- trunk/projects/backport/.depend 2005-12-27 16:27:35 UTC (rev 2335)
+++ trunk/projects/backport/.depend 2005-12-27 22:53:29 UTC (rev 2336)
@@ -0,0 +1,6 @@
+deblib_Files.cmo: deblib_Files.cmi
+deblib_Files.cmx: deblib_Files.cmi
+deblib_Get.cmo: deblib_Get.cmi
+deblib_Get.cmx: deblib_Get.cmi
+backport.cmo: deblib_Files.cmi
+backport.cmx: deblib_Files.cmx
Added: trunk/projects/backport/Makefile
===================================================================
--- trunk/projects/backport/Makefile 2005-12-27 16:27:35 UTC (rev 2335)
+++ trunk/projects/backport/Makefile 2005-12-27 22:53:29 UTC (rev 2336)
@@ -0,0 +1,79 @@
+#
+# Generic makefile for OCaml
+#
+# Author: Stefano Zacchiroli <zack at bononia.it>
+#
+# Created: Tue, 16 Aug 2005 21:51:04 +0200 zack
+# Last-Modified: Wed, 19 Oct 2005 13:05:52 +0200 zack
+#
+
+MODULES = \
+ deblib_Files \
+ deblib_Get \
+ $(NULL)
+BIN = backport
+PACKAGES = curl str extlib deblib unix
+
+OCAMLFIND = ocamlfind
+CAMLP4 = camlp4o
+CFLAGS = -pp $(CAMLP4)
+ifneq ($(strip $(PACKAGES)),)
+CFLAGS += -package "$(PACKAGES)"
+endif
+LDFLAGS = -linkpkg
+OCAMLC = $(OCAMLFIND) ocamlc $(CFLAGS)
+OCAMLOPT = $(OCAMLFIND) ocamlopt $(CFLAGS)
+OCAMLDEP = $(OCAMLFIND) ocamldep $(CFLAGS)
+OCAMLLEX = ocamllex
+OCAMLYACC = ocamlyacc
+NULL =
+
+MLS = $(patsubst %,%.ml,$(MODULES))
+MLIS = $(patsubst %,%.mli,$(MODULES))
+CMIS = $(patsubst %,%.cmi,$(MODULES))
+CMOS = $(patsubst %,%.cmo,$(MODULES))
+CMXS = $(patsubst %,%.cmx,$(MODULES))
+MLLS := $(wildcard *.mll)
+MLYS := $(wildcard *.mly)
+OS = $(patsubst %,%.o,$(MODULES))
+
+all: $(BIN) bpo_version
+opt: $(BIN).opt bpo_version.opt
+
+bpo_version: bpo_version.ml
+ ocamlfind opt -package deblib,unix -linkpkg -o $@ $<
+# bpo_version: bpo_version.ml
+# ocamlfind ocamlc -package deblib,unix -linkpkg -o $@ $<
+# bpo_version.opt: bpo_version.ml
+# ocamlfind opt -package deblib,unix -linkpkg -o $@ $<
+
+$(BIN): $(CMOS) $(BIN).ml
+ $(OCAMLC) $(LDFLAGS) $^ -o $@
+$(BIN).opt: $(CMXS) $(BIN).ml
+ $(OCAMLOPT) $(LDFLAGS) $^ -o $@
+
+%.cmi: %.mli
+ $(OCAMLC) -c $<
+%.cmo %.cmi: %.ml
+ $(OCAMLC) -c $<
+%.cmx: %.ml
+ $(OCAMLOPT) -c $<
+%.ml: %.mll
+ $(OCAMLLEX) $<
+%.ml %.mli: %.mly
+ $(OCAMLYACC) $<
+
+clean_extra:
+ rm -f bpo_version bpo_version.opt bpo_version.cm* bpo_version.[ao]
+clean: clean_extra
+ rm -f $(CMIS) $(CMOS) $(CMXS) $(OS) \
+ $(BIN).cmi $(BIN).cmo $(BIN).cmx $(BIN).o \
+ $(BIN) $(BIN).opt \
+ $(patsubst %.mll,%.ml,$(MLLS)) \
+ $(patsubst %.mly,%.ml,$(MLYS)) \
+ $(patsubst %.mly,%.mli,$(MLYS))
+
+depend:
+ $(OCAMLDEP) $(MLS) $(MLIS) $(BIN).ml > .depend
+
+include .depend
Added: trunk/projects/backport/backport.ml
===================================================================
--- trunk/projects/backport/backport.ml 2005-12-27 16:27:35 UTC (rev 2335)
+++ trunk/projects/backport/backport.ml 2005-12-27 22:53:29 UTC (rev 2336)
@@ -0,0 +1,236 @@
+(* Copyright (C) 2005, Stefano Zacchiroli <zack at debian.org>
+ * License: GUN GPL 2
+ *)
+
+open ExtLib
+open Printf
+
+ (** {2 Configuration} *)
+
+let ref_sources =
+ "http://ftp.debian.org/debian/dists/unstable/main/source/Sources.gz"
+let bpo_sources =
+ "http://backports.org/debian/dists/sarge-backports/main/source/Sources.gz"
+let dchroot_name = "bpo"
+let dchroot_root = "/local/zack/chroots/bpo"
+let hooks = [ "/home/zack/dati/source/ocaml/backport/bpo_version" ]
+
+let dpkg_buildpackage_cmd = "dpkg-buildpackage -rfakeroot -uc -us"
+let dchroot_cmd = "dchroot"
+
+ (** {2 Types and exceptions} *)
+
+exception Command_failure of string * int (* executed command, exit code *)
+
+ (** {2 Global settings} *)
+
+let dchroot_tmp = "/backport_tmp" (* inside chroot *)
+let dry_run = ref false
+
+ (** {2 Utilities} *)
+
+let log level s =
+ match level with
+ | `Debug -> printf "D: %s\n%!" s
+ | `Error -> printf "E: %s\n%!" s
+ | `Info -> printf "I: %s\n%!" s
+
+let exec_cmd cmd =
+ if !dry_run then
+ log `Info cmd
+ else
+ let code = Sys.command cmd in
+ if code <> 0 then raise (Command_failure (cmd, code))
+
+let log_of_dsc dsc = sprintf "%s.backport_log" dsc
+
+let dpkgsrc_results_RE = Str.regexp "^dpkg-source: building .* in \\(.*\\)$"
+let dpkgdeb_results_RE =
+ Str.regexp "^dpkg-deb: building package .* in `../\\(.*\\.deb\\)'\\.$"
+let blanks_RE = Str.regexp "[ \t\n\r]+"
+
+let results_of_log logfile =
+ let ic = open_in logfile in
+ let results = ref [] in
+ let add_result r = results := r :: !results in
+ Enum.iter
+ (fun s ->
+ if Str.string_match dpkgsrc_results_RE s 0 then
+ add_result (Str.matched_group 1 s)
+ else if Str.string_match dpkgdeb_results_RE s 0 then
+ add_result (Str.matched_group 1 s))
+ (input_lines ic);
+ close_in ic;
+ List.rev !results
+
+let files_of_srcpkg pkg =
+ let suffixes = [ ".dsc"; ".tar.gz"; ".diff.gz" ] in
+ let ic = Unix.open_process_in (sprintf "apt-cache showsrc %s" pkg) in
+ let lexbuf = Lexing.from_channel ic in
+ let showsrc = Deblib_Utils.parse822 lexbuf in
+ ignore (Unix.close_process_in ic);
+ match showsrc with
+ | [ entry ] ->
+ let rec files_of =
+ function
+ | [] -> []
+ | _ :: _ :: fname :: tl ->
+ assert
+ (List.exists (fun suff -> Filename.check_suffix fname suff)
+ suffixes);
+ fname :: files_of tl
+ | _ -> assert false in
+ (try
+ files_of (Str.split blanks_RE (Hashtbl.find entry "Files"))
+ with Not_found -> assert false)
+ | _ -> assert false
+
+let dir_of_dsc dsc =
+ let dsc = Deblib_Files.Dsc.create dsc in
+ sprintf "%s-%s" dsc.Deblib_Files.Dsc.source
+ dsc.Deblib_Files.Dsc.version.Deblib_Version.upstream
+
+ (** {3 chroot handling} *)
+
+let chroot_do cmds =
+ let cmds = String.concat " && " cmds in
+ exec_cmd (sprintf "%s -c %s %s" dchroot_cmd dchroot_name
+ (if cmds <> "" then sprintf "'%s'" cmds else ""))
+
+let ensure_backport_dir () =
+ chroot_do [ sprintf "test -d %s || mkdir -p %s" dchroot_tmp dchroot_tmp ]
+
+let chroot_inject files =
+ ensure_backport_dir ();
+ let files = String.concat " " files in
+ log `Debug ("injecting in chroot: " ^ files);
+ exec_cmd (sprintf "cp %s %s/%s" files dchroot_root dchroot_tmp)
+
+let chroot_localize fname =
+ sprintf "%s/%s/%s" dchroot_root dchroot_tmp (Filename.basename fname)
+
+let chroot_remove files =
+ ensure_backport_dir ();
+ let files = String.concat " " files in
+ log `Debug ("removing from chroot: " ^ files);
+ chroot_do [ sprintf "rm -f %s" files ]
+
+let chroot_eject files =
+ ensure_backport_dir ();
+ let files = String.concat " " (List.map chroot_localize files) in
+ log `Debug ("ejecting from chroot: " ^ files);
+ exec_cmd (sprintf "mv %s ." files)
+
+ (** {2 Backend} *)
+
+let update () = chroot_do [ "apt-get update"; "apt-get upgrade" ]
+let login () = chroot_do []
+let clean () = chroot_do [ sprintf "rm -rf %s/*" dchroot_tmp ]
+
+let get_versions pkg =
+ log `Debug (sprintf "getting reference version of %s" pkg);
+ let ref_src = Deblib_Get.src_tbl_of_url ref_sources in
+ let ref_version =
+ try (Hashtbl.find ref_src pkg).Deblib_Types.src_version
+ with Not_found -> None in
+ log `Debug (sprintf "getting backported version of %s" pkg);
+ let bpo_src = Deblib_Get.src_tbl_of_url bpo_sources in
+ let bpo_version =
+ try (Hashtbl.find bpo_src pkg).Deblib_Types.src_version
+ with Not_found -> None in
+ ref_version, bpo_version
+
+let download_source pkg =
+ log `Debug (sprintf "downloading %s" pkg);
+ exec_cmd (sprintf "apt-get -d source %s" pkg);
+ let files = files_of_srcpkg pkg in
+ let has_suffix suff fname = Filename.check_suffix fname suff in
+ let unbox = function [x] -> x | _ -> assert false in
+ let dsc, rest = List.partition (has_suffix ".dsc") files in
+ let tar, rest = List.partition (has_suffix ".tar.gz") rest in
+ unbox dsc, unbox tar, rest
+
+let backport pkg =
+ let do_backport () =
+ let dsc, tarball, other_files = download_source pkg in
+ at_exit (fun () -> List.iter Sys.remove (dsc :: other_files));
+ let dir = dir_of_dsc dsc in
+ exec_cmd (sprintf "dpkg-source -x %s" dsc);
+ log `Debug "executing pre-backporting hooks ...";
+ (match hooks with
+ | [] -> ()
+ | _ -> exec_cmd (sprintf "cd %s && %s" dir (String.concat " && " hooks)));
+ let tempfile = Filename.temp_file "backport." ".tmp" in
+ at_exit (fun () -> Sys.remove tempfile);
+ log `Debug "creating backported source package ...";
+ exec_cmd (sprintf "dpkg-source -b %s | tee %s" dir tempfile);
+ exec_cmd (sprintf "rm -rf %s" dir);
+ let new_src_files = results_of_log tempfile in
+ let new_dsc = List.hd (List.rev new_src_files) in
+ let logfile = log_of_dsc new_dsc in
+ let new_dir = dir_of_dsc new_dsc in
+ assert (Filename.check_suffix new_dsc ".dsc");
+ chroot_inject (tarball :: new_src_files);
+ log `Debug "building backported package ...";
+ chroot_do [
+ sprintf "cd %s" dchroot_tmp;
+ sprintf "dpkg-source -x %s" (Filename.basename new_dsc);
+ sprintf "cd %s" new_dir;
+ sprintf "%s 2>&1 | tee -a ../%s" dpkg_buildpackage_cmd logfile ];
+ chroot_eject [ logfile ];
+ let gen_files = results_of_log logfile in
+ chroot_eject gen_files;
+ chroot_remove new_src_files;
+ log `Info "Backport done.";
+ log `Info (sprintf "Result: %s" (String.concat " " gen_files)) in
+ let log_versions ref bpo =
+ log `Info (sprintf "latest reference version is: %s"
+ (Deblib_Version.to_string ref));
+ log `Info (sprintf "latest backported version is: %s"
+ (Deblib_Version.to_string bpo)) in
+ match get_versions pkg with
+ | Some ref_version, Some bpo_version
+ when Deblib_Version.compare ref_version bpo_version > 1 ->
+ log `Info (sprintf "source package %s need backporting" pkg);
+ log_versions ref_version bpo_version;
+ do_backport ()
+ | Some ref_version, None ->
+ log `Info (sprintf "source package %s is missing, backporting it" pkg);
+ do_backport ()
+ | Some ref_version, Some bpo_version ->
+ log `Info (sprintf "no need to backport source package %s" pkg);
+ log_versions ref_version bpo_version
+ | None, _ ->
+ log `Error (sprintf
+ "can't backport source package %s, it is not available" pkg)
+
+let init () = Curl.global_init Curl.CURLINIT_GLOBALALL
+
+ (** {2 Frontend} *)
+
+let main () =
+ let action = ref None in
+ let set_action a () = action := Some a in
+ let args = ref [] in
+ let arg_spec = [
+ "-update", Arg.Unit (set_action `Update), "update backport's chroot";
+ "-login", Arg.Unit (set_action `Login), "login into backport's chroot";
+ "-clean", Arg.Unit (set_action `Clean), "clean backport's chroot";
+ "-build", Arg.Unit (set_action `Build), "backport a (source) package";
+ "-dry-run", Arg.Set dry_run, "no action, simulation only";
+(* "-v", Arg.Unit increase_verbosity, "increase verbosity"; *)
+ ] in
+ let usage_msg = "Usage: backport.ml ACTION [ OPTION ... ] [ ARG ... ]" in
+ let die_usage () = Arg.usage arg_spec usage_msg; exit 2 in
+ Arg.parse arg_spec (fun s -> args := s :: !args) usage_msg;
+ init ();
+ match !action with
+ | Some `Update -> update ()
+ | Some `Login -> login ()
+ | Some `Clean -> clean ()
+ | Some `Build ->
+ (match !args with [ pkg ] -> backport pkg | _ -> die_usage ())
+ | _ -> die_usage ()
+
+let _ = main ()
+
Added: trunk/projects/backport/bpo_version.ml
===================================================================
--- trunk/projects/backport/bpo_version.ml 2005-12-27 16:27:35 UTC (rev 2335)
+++ trunk/projects/backport/bpo_version.ml 2005-12-27 22:53:29 UTC (rev 2336)
@@ -0,0 +1,29 @@
+(* Copyright (C) 2005, Stefano Zacchiroli <zack at debian.org>
+ * License: GUN GPL 2
+ *)
+
+(** To be invoked inside an unpacked debian source package.
+ * After execution debian/changelog will contain an additional entry suitable
+ * for backporting according to the backports.org rules *)
+
+open Printf
+
+let cur_version =
+ let ic =
+ Unix.open_process_in
+ "dpkg-parsechangelog | grep ^Version | cut -f 2 -d' '" in
+ let raw_version = input_line ic in
+ Deblib_Version.create raw_version
+
+let bpo_version =
+ let v = Deblib_Version.decrease_debian cur_version in
+ { v with Deblib_Version.debian = v.Deblib_Version.debian ^ "bpo1" }
+
+let _ =
+ let cmd =
+ sprintf ("dch --force-bad-version --newversion %s "
+ ^^ "'Backported to http://backports.org'")
+ (Deblib_Version.to_string bpo_version) in
+ print_endline cmd;
+ exit (Sys.command cmd)
+
Added: trunk/projects/backport/deblib_Files.ml
===================================================================
--- trunk/projects/backport/deblib_Files.ml 2005-12-27 16:27:35 UTC (rev 2335)
+++ trunk/projects/backport/deblib_Files.ml 2005-12-27 22:53:29 UTC (rev 2336)
@@ -0,0 +1,70 @@
+(* Copyright (C) 2005, Stefano Zacchiroli <zack at debian.org>
+ * License: GUN GPL 2
+ *)
+
+open Printf
+
+exception Malformed of string
+
+let underscore_regexp = Str.regexp "_"
+
+let create_gen suffix alt_suffix s =
+ let s, alt =
+ if Filename.check_suffix s suffix then
+ Filename.chop_suffix s suffix,
+ Filename.check_suffix s alt_suffix
+ else
+ raise (Malformed s) in
+ match Str.split underscore_regexp s with
+ | [name; version] -> name, version, alt
+ | _ -> raise (Malformed s)
+
+let to_string_gen suffix alt_suffix source version alt =
+ sprintf "%s_%s%s" source (Deblib_Version.to_string version)
+ (if alt then alt_suffix else suffix)
+
+module Dsc =
+struct
+ type t = {
+ source: string;
+ version: Deblib_Version.t;
+ }
+
+ let create s =
+ let name, version, _ = create_gen ".dsc" "" s in
+ { source = name; version = Deblib_Version.create version }
+
+ let to_string t = to_string_gen ".dsc" "" t.source t.version false
+end
+
+module Diff =
+struct
+ type t = {
+ source: string;
+ version: Deblib_Version.t;
+ }
+
+ let create s =
+ let name, version, _ = create_gen ".diff.gz" "" s in
+ { source = name; version = Deblib_Version.create version }
+
+ let to_string t = to_string_gen ".diff.gz" "" t.source t.version false
+end
+
+module Tar =
+struct
+ type t = {
+ source: string;
+ version: Deblib_Version.t;
+ native: bool;
+ }
+
+ let create s =
+ let name, version, non_native = create_gen ".tar.gz" ".orig.tar.gz" s in
+ { source = name; version = Deblib_Version.create version;
+ native = not non_native }
+
+ let to_string t =
+ to_string_gen ".tar.gz" ".orig.tar.gz" t.source t.version (not t.native)
+end
+
Added: trunk/projects/backport/deblib_Files.mli
===================================================================
--- trunk/projects/backport/deblib_Files.mli 2005-12-27 16:27:35 UTC (rev 2335)
+++ trunk/projects/backport/deblib_Files.mli 2005-12-27 22:53:29 UTC (rev 2336)
@@ -0,0 +1,46 @@
+(* Copyright (C) 2005, Stefano Zacchiroli <zack at debian.org>
+ * License: GUN GPL 2
+ *)
+
+exception Malformed of string
+
+(** {2 .dsc files} *)
+
+module Dsc:
+sig
+ type t = {
+ source: string;
+ version: Deblib_Version.t;
+ }
+
+ val create: string -> t
+ val to_string: t -> string
+end
+
+(** {2 .tar.gz files} *)
+
+module Tar:
+sig
+ type t = {
+ source: string;
+ version: Deblib_Version.t; (** assert (version.Deblib_Version.debian="") *)
+ native: bool; (** true for Debian native packages (i.e. no .orig.tar.gz) *)
+ }
+
+ val create: string -> t
+ val to_string: t -> string
+end
+
+(** {2 .diff.gz files} *)
+
+module Diff:
+sig
+ type t = {
+ source: string;
+ version: Deblib_Version.t;
+ }
+
+ val create: string -> t
+ val to_string: t -> string
+end
+
Added: trunk/projects/backport/deblib_Get.ml
===================================================================
--- trunk/projects/backport/deblib_Get.ml 2005-12-27 16:27:35 UTC (rev 2335)
+++ trunk/projects/backport/deblib_Get.ml 2005-12-27 22:53:29 UTC (rev 2336)
@@ -0,0 +1,38 @@
+(* Copyright (C) 2005, Stefano Zacchiroli <zack at debian.org>
+ * License: GUN GPL 2
+ *)
+
+open Printf
+
+let safe_remove fname = if Sys.file_exists fname then Sys.remove fname
+
+let retrieve_to_tmp url = (** URL -> body string *)
+ let conn = new Curl.handle in
+ let name, oc = Filename.open_temp_file "Deblib_Get." ".tmp" in
+ at_exit (fun () -> safe_remove name);
+ conn#set_writefunction (fun s -> output_string oc s);
+ conn#set_url url;
+ conn#perform;
+ close_out oc;
+ name
+
+let parse822url url =
+ let tempfile = retrieve_to_tmp url in
+ let ic, close_fun =
+ match url with
+ | url when Filename.check_suffix url ".gz" ->
+ Unix.open_process_in (sprintf "gunzip -c %s" tempfile),
+ (fun ic -> ignore (Unix.close_process_in ic))
+ | url when Filename.check_suffix url ".bz2" ->
+ Unix.open_process_in (sprintf "bunzip2 -c %s" tempfile),
+ (fun ic -> ignore (Unix.close_process_in ic))
+ | url -> open_in tempfile, close_in in
+ let lexbuf = Lexing.from_channel ic in
+ let res = Deblib_Utils.parse822 lexbuf in
+ close_fun ic;
+ Sys.remove tempfile;
+ res
+
+let src_tbl_of_url url = Deblib_Utils.src_tbl_of_stanza_list (parse822url url)
+let bin_tbl_of_url url = Deblib_Utils.bin_tbl_of_stanza_list (parse822url url)
+
Added: trunk/projects/backport/deblib_Get.mli
===================================================================
--- trunk/projects/backport/deblib_Get.mli 2005-12-27 16:27:35 UTC (rev 2335)
+++ trunk/projects/backport/deblib_Get.mli 2005-12-27 22:53:29 UTC (rev 2336)
@@ -0,0 +1,10 @@
+(* Copyright (C) 2005, Stefano Zacchiroli <zack at debian.org>
+ * License: GUN GPL 2
+ *)
+
+(** Strings given below should be in a format supported by curl.
+ * URLs ending in .gz/.bz2 are extracted before parsing. *)
+
+val src_tbl_of_url: string -> (string, Deblib_Types.source_package) Hashtbl.t
+val bin_tbl_of_url: string -> (string, Deblib_Types.binary_package) Hashtbl.t
+
More information about the Pkg-ocaml-maint-commits
mailing list