code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix utils)
  #:use-module (guix config)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-39)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 ftw)
  #:autoload   (rnrs io ports) (make-custom-binary-input-port)
  #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
  #:use-module (guix memoization)
  #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively))
  #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
  #:use-module (ice-9 format)
  #:autoload   (ice-9 popen)  (open-pipe*)
  #:autoload   (ice-9 rdelim) (read-line)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module ((ice-9 iconv) #:prefix iconv:)
  #:use-module (system foreign)
  #:re-export (memoize)         ; for backwards compatibility
  #:export (strip-keyword-arguments
            default-keyword-arguments
            substitute-keyword-arguments
            ensure-keyword-arguments

            current-source-directory

            <location>
            location
            location?
            location-file
            location-line
            location-column
            source-properties->location
            location->source-properties

            &error-location
            error-location?
            error-location

            &fix-hint
            fix-hint?
            condition-fix-hint

            nix-system->gnu-triplet
            gnu-triplet->nix-system
            %current-system
            %current-target-system
            package-name->name+version
            target-mingw?
            target-arm32?
            target-64bit?
            version-compare
            version>?
            version>=?
            version-prefix
            version-major+minor
            version-major
            guile-version>?
            version-prefix?
            string-replace-substring
            arguments-from-environment-variable
            file-extension
            file-sans-extension
            compressed-file?
            switch-symlinks
            call-with-temporary-output-file
            call-with-temporary-directory
            with-atomic-file-output

            config-directory
            cache-directory

            readlink*
            edit-expression

            filtered-port
            compressed-port
            decompressed-port
            call-with-decompressed-port
            compressed-output-port
            call-with-compressed-output-port
            canonical-newline-port))

;;;
;;; Filtering & pipes.
;;;

(define (filtered-port command input)
  "Return an input port where data drained from INPUT is filtered through
COMMAND (a list).  In addition, return a list of PIDs that the caller must
wait.  When INPUT is a file port, it must be unbuffered; otherwise, any
buffered data is lost."
  (let loop ((input input)
             (pids  '()))
    (if (file-port? input)
        (match (pipe)
          ((in . out)
           (match (primitive-fork)
             (0
              (dynamic-wind
                (const #f)
                (lambda ()
                  (close-port in)
                  (close-port (current-input-port))
                  (dup2 (fileno input) 0)
                  (close-port (current-output-port))
                  (dup2 (fileno out) 1)
                  (catch 'system-error
                    (lambda ()
                      (apply execl (car command) command))
                    (lambda args
                      (format (current-error-port)
                              "filtered-port: failed to execute '~{~a ~}': ~a~%"
                              command (strerror (system-error-errno args))))))
                (lambda ()
                  (primitive-_exit 1))))
             (child
              (close-port out)
              (values in (cons child pids))))))

        ;; INPUT is not a file port, so fork just for the sake of tunneling it
        ;; through a file port.
        (match (pipe)
          ((in . out)
           (match (primitive-fork)
             (0
              (dynamic-wind
                (const #t)
                (lambda ()
                  (close-port in)
                  (dump-port input out))
                (lambda ()
                  (close-port input)
                  (false-if-exception (close out))
                  (primitive-_exit 0))))
             (child
              (close-port input)
              (close-port out)
              (loop in (cons child pids)))))))))

(define (decompressed-port compression input)
  "Return an input port where INPUT is decompressed according to COMPRESSION,
a symbol such as 'xz."
  (match compression
    ((or #f 'none) (values input '()))
    ('bzip2        (filtered-port `(,%bzip2 "-dc") input))
    ('xz           (filtered-port `(,%xz "-dc") input))
    ('gzip         (filtered-port `(,%gzip "-dc") input))
    (else          (error "unsupported compression scheme" compression))))

(define (compressed-port compression input)
  "Return an input port where INPUT is decompressed according to COMPRESSION,
a symbol such as 'xz."
  (match compression
    ((or #f 'none) (values input '()))
    ('bzip2        (filtered-port `(,%bzip2 "-c") input))
    ('xz           (filtered-port `(,%xz "-c") input))
    ('gzip         (filtered-port `(,%gzip "-c") input))
    (else          (error "unsupported compression scheme" compression))))

(define (call-with-decompressed-port compression port proc)
  "Call PROC with a wrapper around PORT, a file port, that decompresses data
read from PORT according to COMPRESSION, a symbol such as 'xz."
  (let-values (((decompressed pids)
                (decompressed-port compression port)))
    (dynamic-wind
      (const #f)
      (lambda ()
        (proc decompressed))
      (lambda ()
        (close-port decompressed)
        (unless (every (compose zero? cdr waitpid) pids)
          (error "decompressed-port failure" pids))))))

(define (filtered-output-port command output)
  "Return an output port.  Data written to that port is filtered through
COMMAND and written to OUTPUT, an output file port.  In addition, return a
list of PIDs to wait for.  OUTPUT must be unbuffered; otherwise, any buffered
data is lost."
  (match (pipe)
    ((in . out)
     (match (primitive-fork)
       (0
        (dynamic-wind
          (const #f)
          (lambda ()
            (close-port out)
            (close-port (current-input-port))
            (dup2 (fileno in) 0)
            (close-port (current-output-port))
            (dup2 (fileno output) 1)
            (catch 'system-error
              (lambda ()
                (apply execl (car command) command))
              (lambda args
                (format (current-error-port)
                        "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
                        command (strerror (system-error-errno args))))))
          (lambda ()
            (primitive-_exit 1))))
       (child
        (close-port in)
        (values out (list child)))))))

(define* (compressed-output-port compression output
                                 #:key (options '()))
  "Return an output port whose input is compressed according to COMPRESSION,
a symbol such as 'xz, and then written to OUTPUT.  In addition return a list
of PIDs to wait for.  OPTIONS is a list of strings passed to the compression
program--e.g., '(\"--fast\")."
  (match compression
    ((or #f 'none) (values output '()))
    ('bzip2        (filtered-output-port `(,%bzip2 "-c" ,@options) output))
    ('xz           (filtered-output-port `(,%xz "-c" ,@options) output))
    ('gzip         (filtered-output-port `(,%gzip "-c" ,@options) output))
    (else          (error "unsupported compression scheme" compression))))

(define* (call-with-compressed-output-port compression port proc
                                           #:key (options '()))
  "Call PROC with a wrapper around PORT, a file port, that compresses data
that goes to PORT according to COMPRESSION, a symbol such as 'xz.  OPTIONS is
a list of command-line arguments passed to the compression program."
  (let-values (((compressed pids)
                (compressed-output-port compression port
                                        #:options options)))
    (dynamic-wind
      (const #f)
      (lambda ()
        (proc compressed))
      (lambda ()
        (close-port compressed)
        (unless (every (compose zero? cdr waitpid) pids)
          (error "compressed-output-port failure" pids))))))

(define* (edit-expression source-properties proc #:key (encoding "UTF-8"))
  "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should
be a procedure that takes the original expression in string and returns a new
one.  ENCODING will be used to interpret all port I/O, it default to UTF-8.
This procedure returns #t on success."
  (with-fluids ((%default-port-encoding encoding))
    (let* ((file   (assq-ref source-properties 'filename))
           (line   (assq-ref source-properties 'line))
           (column (assq-ref source-properties 'column))
           (in     (open-input-file file))
           ;; The start byte position of the expression.
           (start  (begin (while (not (and (= line (port-line in))
                                           (= column (port-column in))))
                            (when (eof-object? (read-char in))
                              (error (format #f "~a: end of file~%" in))))
                          (ftell in)))
           ;; The end byte position of the expression.
           (end    (begin (read in) (ftell in))))
      (seek in 0 SEEK_SET) ; read from the beginning of the file.
      (let* ((pre-bv  (get-bytevector-n in start))
             ;; The expression in string form.
             (str     (iconv:bytevector->string
                       (get-bytevector-n in (- end start))
                       (port-encoding in)))
             (post-bv (get-bytevector-all in))
             (str*    (proc str)))
        ;; Verify the edited expression is still a scheme expression.
        (call-with-input-string str* read)
        ;; Update the file with edited expression.
        (with-atomic-file-output file
          (lambda (out)
            (put-bytevector out pre-bv)
            (display str* out)
            ;; post-bv maybe the end-of-file object.
            (when (not (eof-object? post-bv))
              (put-bytevector out post-bv))
            #t))))))

;;;
;;; Keyword arguments.
;;;

(define (strip-keyword-arguments keywords args)
  "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
  (let loop ((args   args)
             (result '()))
    (match args
      (()
       (reverse result))
      (((? keyword? kw) arg . rest)
       (loop rest
             (if (memq kw keywords)
                 result
                 (cons* arg kw result))))
      ((head . tail)
       (loop tail (cons head result))))))

(define (default-keyword-arguments args defaults)
  "Return ARGS augmented with any keyword/value from DEFAULTS for
keywords not already present in ARGS."
  (let loop ((defaults defaults)
             (args     args))
    (match defaults
      ((kw value rest ...)
       (loop rest
             (if (memq kw args)
                 args
                 (cons* kw value args))))
      (()
       args))))

(define-syntax collect-default-args
  (syntax-rules ()
    ((_)
     '())
    ((_ (_ _) rest ...)
     (collect-default-args rest ...))
    ((_ (kw _ dflt) rest ...)
     (cons* kw dflt (collect-default-args rest ...)))))

(define-syntax substitute-keyword-arguments
  (syntax-rules ()
    "Return a new list of arguments where the value for keyword arg KW is
replaced by EXP.  EXP is evaluated in a context where VAR is bound to the
previous value of the keyword argument, or DFLT if given."
    ((_ original-args ((kw var dflt ...) exp) ...)
     (let loop ((args (default-keyword-arguments
                        original-args
                        (collect-default-args (kw var dflt ...) ...)))
                (before '()))
       (match args
         ((kw var rest (... ...))
          (loop rest (cons* exp kw before)))
         ...
         ((x rest (... ...))
          (loop rest (cons x before)))
         (()
          (reverse before)))))))

(define (delkw kw lst)
  "Remove KW and its associated value from LST, a keyword/value list such
as '(#:foo 1 #:bar 2)."
  (let loop ((lst    lst)
             (result '()))
    (match lst
      (()
       (reverse result))
      ((kw? value rest ...)
       (if (eq? kw? kw)
           (append (reverse result) rest)
           (loop rest (cons* value kw? result)))))))

(define (ensure-keyword-arguments args kw/values)
  "Force the keywords arguments KW/VALUES in the keyword argument list ARGS.
For instance:

  (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
  => (#:foo 2)

  (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
  => (#:foo 2 #:bar 3)

  (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))
  => (#:foo 42 #:bar 3)
"
  (let loop ((args      args)
             (kw/values kw/values)
             (result    '()))
    (match args
      (()
       (append (reverse result) kw/values))
      ((kw value rest ...)
       (match (memq kw kw/values)
         ((_ value . _)
          (loop rest (delkw kw kw/values) (cons* value kw result)))
         (#f
          (loop rest kw/values (cons* value kw result))))))))

;;;
;;; System strings.
;;;

(define* (nix-system->gnu-triplet
          #:optional (system (%current-system)) (vendor "unknown"))
  "Return a guess of the GNU triplet corresponding to Nix system
identifier SYSTEM."
  (match system
    ("armhf-linux"
     (string-append "arm-" vendor "-linux-gnueabihf"))
    (_
     (let* ((dash (string-index system #\-))
            (arch (substring system 0 dash))
            (os   (substring system (+ 1 dash))))
       (string-append arch
                      "-" vendor "-"
                      (if (string=? os "linux")
                          "linux-gnu"
                          os))))))

(define (gnu-triplet->nix-system triplet)
  "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
returned by `config.guess'."
  (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
                        =>
                        (lambda (m)
                          (string-append "i686-" (match:substring m 1))))
                       (else triplet))))
    (cond ((string-match "^arm[^-]*-([^-]+-)?linux-gnueabihf" triplet)
           "armhf-linux")
          ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
           =>
           (lambda (m)
             ;; Nix omits `-gnu' for GNU/Linux.
             (string-append (match:substring m 1) "-linux")))
          ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
           =>
           (lambda (m)
             ;; Nix strip the version number from names such as `gnu0.3',
             ;; `darwin10.2.0', etc., and always strips the vendor part.
             (string-append (match:substring m 1) "-"
                            (match:substring m 3))))
          (else triplet))))

(define %current-system
  ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
  ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
  (make-parameter %system))

(define %current-target-system
  ;; Either #f or a GNU triplet representing the target system we are
  ;; cross-building to.
  (make-parameter #f))

(define* (package-name->name+version spec
                                     #:optional (delimiter #\@))
  "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\"
and \"0.9.1b\".  When the version part is unavailable, SPEC and #f are
returned.  Both parts must not contain any '@'.  Optionally, DELIMITER can be
a character other than '@'."
  (match (string-rindex spec delimiter)
    (#f  (values spec #f))
    (idx (values (substring spec 0 idx)
                 (substring spec (1+ idx))))))

(define* (target-mingw? #:optional (target (%current-target-system)))
  (and target
       (string-suffix? "-mingw32" target)))

(define (target-arm32?)
  (string-prefix? "arm" (or (%current-target-system) (%current-system))))

(define (target-64bit?)
  (let ((system (or (%current-target-system) (%current-system))))
    (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64"))))

(define version-compare
  (let ((strverscmp
         (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
                        (error "could not find `strverscmp' (from GNU libc)"))))
           (pointer->procedure int sym (list '* '*)))))
    (lambda (a b)
      "Return '> when A denotes a newer version than B,
'< when A denotes a older version than B,
or '= when they denote equal versions."
      (let ((result (strverscmp (string->pointer a) (string->pointer b))))
        (cond ((positive? result) '>)
              ((negative? result) '<)
              (else '=))))))

(define (version-prefix version-string num-parts)
  "Truncate version-string to the first num-parts components of the version.
For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\""
  (string-join (take (string-split version-string #\.) num-parts) "."))

(define (version-major+minor version-string)
  "Return \"<major>.<minor>\", where major and minor are the major and
minor version numbers from version-string."
  (version-prefix version-string 2))

(define (version-major version-string)
  "Return the major version number as string from the version-string."
  (version-prefix version-string 1))

(define (version>? a b)
  "Return #t when A denotes a version strictly newer than B."
  (eq? '> (version-compare a b)))

(define (version>=? a b)
  "Return #t when A denotes a version newer or equal to B."
  (case (version-compare a b)
    ((> =) #t)
    (else #f)))

(define (guile-version>? str)
  "Return #t if the running Guile version is greater than STR."
  ;; Note: Using (version>? (version) "2.0.5") or similar doesn't work,
  ;; because the result of (version) can have a prefix, like "2.0.5-deb1".
  (version>? (string-append (major-version) "."
                            (minor-version) "."
                            (micro-version))
             str))

(define version-prefix?
  (let ((not-dot (char-set-complement (char-set #\.))))
    (lambda (v1 v2)
      "Return true if V1 is a version prefix of V2:

  (version-prefix? \"4.1\" \"4.16.2\") => #f
  (version-prefix? \"4.1\" \"4.1.2\") => #t
"
      (define (list-prefix? lst1 lst2)
        (match lst1
          (() #t)
          ((head1 tail1 ...)
           (match lst2
             (() #f)
             ((head2 tail2 ...)
              (and (equal? head1 head2)
                   (list-prefix? tail1 tail2)))))))

      (list-prefix? (string-tokenize v1 not-dot)
                    (string-tokenize v2 not-dot)))))

(define (file-extension file)
  "Return the extension of FILE or #f if there is none."
  (let ((dot (string-rindex file #\.)))
    (and dot (substring file (+ 1 dot) (string-length file)))))

(define (file-sans-extension file)
  "Return the substring of FILE without its extension, if any."
  (let ((dot (string-rindex file #\.)))
    (if dot
        (substring file 0 dot)
        file)))

(define (compressed-file? file)
  "Return true if FILE denotes a compressed file."
  (->bool (member (file-extension file)
                  '("gz" "bz2" "xz" "lz" "lzma" "tgz" "tbz2" "zip"))))

(define (switch-symlinks link target)
  "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
both when LINK already exists and when it does not."
  (let ((pivot (string-append link ".new")))
    (symlink target pivot)
    (rename-file pivot link)))

(define* (string-replace-substring str substr replacement
                                   #:optional
                                   (start 0)
                                   (end (string-length str)))
  "Replace all occurrences of SUBSTR in the START--END range of STR by
REPLACEMENT."
  (match (string-length substr)
    (0
     (error "string-replace-substring: empty substring"))
    (substr-length
     (let loop ((start  start)
                (pieces (list (substring str 0 start))))
       (match (string-contains str substr start end)
         (#f
          (string-concatenate-reverse
           (cons (substring str start) pieces)))
         (index
          (loop (+ index substr-length)
                (cons* replacement
                       (substring str start index)
                       pieces))))))))

(define (arguments-from-environment-variable variable)
  "Retrieve value of environment variable denoted by string VARIABLE in the
form of a list of strings (`char-set:graphic' tokens) suitable for consumption
by `args-fold', if VARIABLE is defined, otherwise return an empty list."
  (let ((env (getenv variable)))
    (if env
        (string-tokenize env char-set:graphic)
        '())))

(define (call-with-temporary-output-file proc)
  "Call PROC with a name of a temporary file and open output port to that
file; close the file and delete it when leaving the dynamic extent of this
call."
  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
         (template  (string-append directory "/guix-file.XXXXXX"))
         (out       (mkstemp! template)))
    (dynamic-wind
      (lambda ()
        #t)
      (lambda ()
        (proc template out))
      (lambda ()
        (false-if-exception (close out))
        (false-if-exception (delete-file template))))))

(define (call-with-temporary-directory proc)
  "Call PROC with a name of a temporary directory; close the directory and
delete it when leaving the dynamic extent of this call."
  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
         (template  (string-append directory "/guix-directory.XXXXXX"))
         (tmp-dir   (mkdtemp! template)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (proc tmp-dir))
      (lambda ()
        (false-if-exception (delete-file-recursively tmp-dir))))))

(define (with-atomic-file-output file proc)
  "Call PROC with an output port for the file that is going to replace FILE.
Upon success, FILE is atomically replaced by what has been written to the
output port, and PROC's result is returned."
  (let* ((template (string-append file ".XXXXXX"))
         (out      (mkstemp! template)))
    (with-throw-handler #t
      (lambda ()
        (let ((result (proc out)))
          (fdatasync out)
          (close-port out)
          (rename-file template file)
          result))
      (lambda (key . args)
        (false-if-exception (delete-file template))
        (close-port out)))))

(define* (xdg-directory variable suffix #:key (ensure? #t))
  "Return the name of the XDG directory that matches VARIABLE and SUFFIX,
after making sure that it exists if ENSURE? is true.  VARIABLE is an
environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like
\"/.config\".  Honor the XDG specs,
<http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
  (let ((dir (and=> (or (getenv variable)
                        (and=> (or (getenv "HOME")
                                   (passwd:dir (getpwuid (getuid))))
                               (cut string-append <> suffix)))
                    (cut string-append <> "/guix"))))
    (when ensure?
      (mkdir-p dir))
    dir))

(define config-directory
  (cut xdg-directory "XDG_CONFIG_HOME" "/.config" <...>))

(define cache-directory
  (cut xdg-directory "XDG_CACHE_HOME" "/.cache" <...>))

(define (readlink* file)
  "Call 'readlink' until the result is not a symlink."
  (define %max-symlink-depth 50)

  (let loop ((file  file)
             (depth 0))
    (define (absolute target)
      (if (absolute-file-name? target)
          target
          (string-append (dirname file) "/" target)))

    (if (>= depth %max-symlink-depth)
        file
        (call-with-values
            (lambda ()
              (catch 'system-error
                (lambda ()
                  (values #t (readlink file)))
                (lambda args
                  (let ((errno (system-error-errno args)))
                    (if (or (= errno EINVAL))
                        (values #f file)
                        (apply throw args))))))
          (lambda (success? target)
            (if success?
                (loop (absolute target) (+ depth 1))
                file))))))

(define (canonical-newline-port port)
  "Return an input port that wraps PORT such that all newlines consist
  of a single carriage return."
  (define (get-position)
    (if (port-has-port-position? port) (port-position port) #f))
  (define (set-position! position)
    (if (port-has-set-port-position!? port)
        (set-port-position! position port)
        #f))
  (define (close) (close-port port))
  (define (read! bv start n)
    (let loop ((count 0)
               (byte (get-u8 port)))
      (cond ((eof-object? byte) count)
            ((= count (- n 1))
             (bytevector-u8-set! bv (+ start count) byte)
             n)
            ;; XXX: consume all LFs even if not followed by CR.
            ((eqv? byte (char->integer #\return)) (loop count (get-u8 port)))
            (else
             (bytevector-u8-set! bv (+ start count) byte)
             (loop (+ count 1) (get-u8 port))))))
  (make-custom-binary-input-port "canonical-newline-port"
                                 read!
                                 get-position
                                 set-position!
                                 close))

;;;
;;; Source location.
;;;

(define (absolute-dirname file)
  "Return the absolute name of the directory containing FILE, or #f upon
failure."
  (match (search-path %load-path file)
    (#f #f)
    ((? string? file)
     ;; If there are relative names in %LOAD-PATH, FILE can be relative and
     ;; needs to be canonicalized.
     (if (string-prefix? "/" file)
         (dirname file)
         (canonicalize-path (dirname file))))))

(define-syntax current-source-directory
  (lambda (s)
    "Return the absolute name of the current directory, or #f if it could not
be determined."
    (syntax-case s ()
      ((_)
       (match (assq 'filename (or (syntax-source s) '()))
         (('filename . (? string? file-name))
          ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
          ;; can be relative.  In that case, we try to find out at run time
          ;; the absolute file name by looking at %LOAD-PATH; doing this at
          ;; run time rather than expansion time is necessary to allow files
          ;; to be moved on the file system.
          (cond ((not file-name)
                 #f)                ;raising an error would upset Geiser users
                ((string-prefix? "/" file-name)
                 (dirname file-name))
                (else
                 #`(absolute-dirname #,file-name))))
         (#f
          #f))))))

;; A source location.
(define-record-type <location>
  (make-location file line column)
  location?
  (file          location-file)                   ; file name
  (line          location-line)                   ; 1-indexed line
  (column        location-column))                ; 0-indexed column

(define (location file line column)
  "Return the <location> object for the given FILE, LINE, and COLUMN."
  (and line column file
       (make-location file line column)))

(define (source-properties->location loc)
  "Return a location object based on the info in LOC, an alist as returned
by Guile's `source-properties', `frame-source', `current-source-location',
etc."
  ;; In accordance with the GCS, start line and column numbers at 1.  Note
  ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
  (match loc
    ((('line . line) ('column . col) ('filename . file)) ;common case
     (and file line col
          (make-location file (+ line 1) col)))
    (#f
     #f)
    (_
     (let ((file (assq-ref loc 'filename))
           (line (assq-ref loc 'line))
           (col  (assq-ref loc 'column)))
       (location file (and line (+ line 1)) col)))))

(define (location->source-properties loc)
  "Return the source property association list based on the info in LOC,
a location object."
  `((line     . ,(and=> (location-line loc) 1-))
    (column   . ,(location-column loc))
    (filename . ,(location-file loc))))

(define-condition-type &error-location &error
  error-location?
  (location  error-location))                     ;<location>

(define-condition-type &fix-hint &condition
  fix-hint?
  (hint condition-fix-hint))                      ;string

;;; Local Variables:
;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix workers)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 match)
  #:use-module (ice-9 q)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module ((guix build syscalls) #:select (set-thread-name))
  #:export (pool?
            make-pool
            pool-enqueue!
            pool-idle?
            eventually))

;;; Commentary:
;;;
;;; This module implements "worker pools".  Worker pools are the low-level
;;; mechanism that's behind futures: there's a fixed set of threads
;;; ("workers") that one can submit work to, and one of them will eventually
;;; pick the submitted tasks.
;;;
;;; Unlike futures, these worker pools are meant to be used for tasks that
;;; have a side-effect.  Thus, we never "touch" a task that was submitted like
;;; we "touch" a future.  Instead, we simply assume that the task will
;;; eventually complete.
;;;
;;; Code:

(define-record-type <pool>
  (%make-pool queue mutex condvar workers busy)
  pool?
  (queue    pool-queue)
  (mutex    pool-mutex)
  (condvar  pool-condition-variable)
  (workers  pool-workers)
  (busy     pool-busy))

(define-syntax-rule (without-mutex mutex exp ...)
  (dynamic-wind
    (lambda ()
      (unlock-mutex mutex))
    (lambda ()
      exp ...)
    (lambda ()
      (lock-mutex mutex))))

(define* (worker-thunk mutex condvar pop-queue
                       #:key idle busy (thread-name "guix worker"))
  "Return the thunk executed by worker threads."
  (define (loop)
    (match (pop-queue)
      (#f                                         ;empty queue
       (idle)
       (wait-condition-variable condvar mutex)
       (busy))
      ((? procedure? proc)
       ;; Release MUTEX while executing PROC.
       (without-mutex mutex
         (catch #t proc
           (const #f)
           (lambda (key . args)
             ;; XXX: In Guile 2.0 ports are not thread-safe, so this could
             ;; crash (Guile 2.2 is fine).
             (display-backtrace (make-stack #t) (current-error-port))
             (print-exception (current-error-port)
                              (and=> (make-stack #t)
                                     (cut stack-ref <> 0))
                              key args))))))
    (loop))

  (lambda ()
    (catch 'system-error
      (lambda ()
        (set-thread-name thread-name))
      (const #f))

    (with-mutex mutex
      (loop))))

(define* (make-pool #:optional (count (current-processor-count))
                    #:key (thread-name "guix worker"))
  "Return a pool of COUNT workers.  Use THREAD-NAME as the name of these
threads as reported by the operating system."
  (let* ((mutex   (make-mutex))
         (condvar (make-condition-variable))
         (queue   (make-q))
         (busy    count)
         (procs   (unfold (cut >= <> count)
                          (lambda (n)
                            (worker-thunk mutex condvar
                                          (lambda ()
                                            (and (not (q-empty? queue))
                                                 (q-pop! queue)))
                                          #:busy (lambda ()
                                                   (set! busy (+ 1 busy)))
                                          #:idle (lambda ()
                                                   (set! busy (- busy 1)))
                                          #:thread-name thread-name))
                          1+
                          0))
         (threads (map (lambda (proc)
                         (call-with-new-thread proc))
                       procs)))
    (%make-pool queue mutex condvar threads (lambda () busy))))

(define (pool-enqueue! pool thunk)
  "Enqueue THUNK for future execution by POOL."
  (with-mutex (pool-mutex pool)
    (enq! (pool-queue pool) thunk)
    (signal-condition-variable (pool-condition-variable pool))))

(define (pool-idle? pool)
  "Return true if POOL doesn't have any task in its queue and all the workers
are currently idle (i.e., waiting for a task)."
  (with-mutex (pool-mutex pool)
    (and (q-empty? (pool-queue pool))
         (zero? ((pool-busy pool))))))

(define-syntax-rule (eventually pool exp ...)
  "Run EXP eventually on one of the workers of POOL."
  (pool-enqueue! pool (lambda () exp ...)))

;;; Local Variables:
;;; eval: (put 'without-mutex 'scheme-indent-function 1)
;;; End:

;;; workers.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix zlib)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 match)
  #:use-module (system foreign)
  #:use-module (guix config)
  #:export (zlib-available?
            make-gzip-input-port
            make-gzip-output-port
            call-with-gzip-input-port
            call-with-gzip-output-port
            %default-buffer-size
            %default-compression-level))

;;; Commentary:
;;;
;;; Bindings to the gzip-related part of zlib's API.  The main limitation of
;;; this API is that it requires a file descriptor as the source or sink.
;;;
;;; Code:

(define %zlib
  ;; File name of zlib's shared library.  When updating via 'guix pull',
  ;; '%libz' might be undefined so protect against it.
  (delay (dynamic-link (if (defined? '%libz)
                           %libz
                           "libz"))))

(define (zlib-available?)
  "Return true if zlib is available, #f otherwise."
  (false-if-exception (force %zlib)))

(define (zlib-procedure ret name parameters)
  "Return a procedure corresponding to C function NAME in libz, or #f if
either zlib or the function could not be found."
  (match (false-if-exception (dynamic-func name (force %zlib)))
    ((? pointer? ptr)
     (pointer->procedure ret ptr parameters))
    (#f
     #f)))

(define-wrapped-pointer-type <gzip-file>
  ;; Scheme counterpart of the 'gzFile' opaque type.
  gzip-file?
  pointer->gzip-file
  gzip-file->pointer
  (lambda (obj port)
    (format port "#<gzip-file ~a>"
            (number->string (object-address obj) 16))))

(define gzerror
  (let ((proc (zlib-procedure '* "gzerror" '(* *))))
    (lambda (gzfile)
      (let* ((errnum* (make-bytevector (sizeof int)))
             (ptr     (proc (gzip-file->pointer gzfile)
                            (bytevector->pointer errnum*))))
        (values (bytevector-sint-ref errnum* 0
                                     (native-endianness) (sizeof int))
                (pointer->string ptr))))))

(define gzdopen
  (let ((proc (zlib-procedure '* "gzdopen" (list int '*))))
    (lambda (fd mode)
      "Open file descriptor FD as a gzip stream with the given MODE.  MODE must
be a string denoting the how FD is to be opened, such as \"r\" for reading or
\"w9\" for writing data compressed at level 9 to FD.  Calling 'gzclose' also
closes FD."
      (let ((result (proc fd (string->pointer mode))))
        (if (null-pointer? result)
            (throw 'zlib-error 'gzdopen)
            (pointer->gzip-file result))))))

(define gzread!
  (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int))))
    (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
      "Read up to COUNT bytes from GZFILE into BV at offset START.  Return the
number of uncompressed bytes actually read; it is zero if COUNT is zero or if
the end-of-stream has been reached."
      (let ((ret (proc (gzip-file->pointer gzfile)
                       (bytevector->pointer bv start)
                       count)))
        (if (< ret 0)
            (throw 'zlib-error 'gzread! ret)
            ret)))))

(define gzwrite
  (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int))))
    (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
      "Write up to COUNT bytes from BV at offset START into GZFILE.  Return
the number of uncompressed bytes written, a strictly positive integer."
      (let ((ret (proc (gzip-file->pointer gzfile)
                       (bytevector->pointer bv start)
                       count)))
        (if (<= ret 0)
            (throw 'zlib-error 'gzwrite ret)
            ret)))))

(define gzbuffer!
  (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int))))
    (lambda (gzfile size)
      "Change the internal buffer size of GZFILE to SIZE bytes."
      (let ((ret (proc (gzip-file->pointer gzfile) size)))
        (unless (zero? ret)
          (throw 'zlib-error 'gzbuffer! ret))))))

(define gzeof?
  (let ((proc (zlib-procedure int "gzeof" '(*))))
    (lambda (gzfile)
      "Return true if the end-of-file has been reached on GZFILE."
      (not (zero? (proc (gzip-file->pointer gzfile)))))))

(define gzclose
  (let ((proc (zlib-procedure int "gzclose" '(*))))
    (lambda (gzfile)
      "Close GZFILE."
      (let ((ret (proc (gzip-file->pointer gzfile))))
        (unless (zero? ret)
          (throw 'zlib-error 'gzclose ret (gzerror gzfile)))))))

;;;
;;; Port interface.
;;;

(define %default-buffer-size
  ;; Default buffer size, as documented in <zlib.h>.
  8192)

(define %default-compression-level
  ;; Z_DEFAULT_COMPRESSION.
  -1)

(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
  "Return an input port that decompresses data read from PORT, a file port.
PORT is automatically closed when the resulting port is closed.  BUFFER-SIZE
is the size in bytes of the internal buffer, 8 KiB by default; using a larger
buffer increases decompression speed.  An error is thrown if PORT contains
buffered input, which would be lost (and is lost anyway)."
  (define gzfile
    (match (drain-input port)
      (""                                         ;PORT's buffer is empty
       ;; 'gzclose' will eventually close the file descriptor beneath PORT.
       ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it,
       ;; so that's no good; revealed ports are no good either because they
       ;; leak (see <https://bugs.gnu.org/28784>); calling 'close-port' after
       ;; 'gzclose' doesn't work either because it leads to a race condition
       ;; (see <https://bugs.gnu.org/29335>).  So we dup and close PORT right
       ;; away.
       (gzdopen (dup (fileno port)) "r"))
      (_
       ;; This is unrecoverable but it's better than having the buffered input
       ;; be lost, leading to unclear end-of-file or corrupt-data errors down
       ;; the path.
       (throw 'zlib-error 'make-gzip-input-port
              "port contains buffered input" port))))

  (define (read! bv start count)
    (gzread! gzfile bv start count))

  (unless (= buffer-size %default-buffer-size)
    (gzbuffer! gzfile buffer-size))

  (close-port port)                               ;we no longer need it
  (make-custom-binary-input-port "gzip-input" read! #f #f
                                 (lambda ()
                                   (gzclose gzfile))))

(define* (make-gzip-output-port port
                                #:key
                                (level %default-compression-level)
                                (buffer-size %default-buffer-size))
  "Return an output port that compresses data at the given LEVEL, using PORT,
a file port, as its sink.  PORT is automatically closed when the resulting
port is closed."
  (define gzfile
    (begin
      (force-output port)                         ;empty PORT's buffer
      (gzdopen (dup (fileno port))
               (string-append "w" (number->string level)))))

  (define (write! bv start count)
    (gzwrite gzfile bv start count))

  (unless (= buffer-size %default-buffer-size)
    (gzbuffer! gzfile buffer-size))

  (close-port port)
  (make-custom-binary-output-port "gzip-output" write! #f #f
                                  (lambda ()
                                    (gzclose gzfile))))

(define* (call-with-gzip-input-port port proc
                                    #:key (buffer-size %default-buffer-size))
  "Call PROC with a port that wraps PORT and decompresses data read from it.
PORT is closed upon completion.  The gzip internal buffer size is set to
BUFFER-SIZE bytes."
  (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (proc gzip))
      (lambda ()
        (close-port gzip)))))

(define* (call-with-gzip-output-port port proc
                                     #:key
                                     (level %default-compression-level)
                                     (buffer-size %default-buffer-size))
  "Call PROC with an output port that wraps PORT and compresses data.  PORT is
close upon completion.  The gzip internal buffer size is set to BUFFER-SIZE
bytes."
  (let ((gzip (make-gzip-output-port port
                                     #:level level
                                     #:buffer-size buffer-size)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (proc gzip))
      (lambda ()
        (close-port gzip)))))

;;; zlib.scm ends here


code:
dnl GNU Guix --- Functional package management for GNU
dnl Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
dnl Copyright © 2014 Mark H Weaver <mhw@netris.org>
dnl Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
dnl
dnl This file is part of GNU Guix.
dnl
dnl GNU Guix is free software; you can redistribute it and/or modify it
dnl under the terms of the GNU General Public License as published by
dnl the Free Software Foundation; either version 3 of the License, or (at
dnl your option) any later version.
dnl
dnl GNU Guix is distributed in the hope that it will be useful, but
dnl WITHOUT ANY WARRANTY; without even the implied warranty of
dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
dnl GNU General Public License for more details.
dnl
dnl You should have received a copy of the GNU General Public License
dnl along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

dnl GUIX_SYSTEM_TYPE
dnl
dnl Determine the Guix host system type, and store it in the
dnl `guix_system' variable.
AC_DEFUN([GUIX_SYSTEM_TYPE], [
  AC_REQUIRE([AC_CANONICAL_HOST])
  AC_PATH_PROG([SED], [sed])

  AC_ARG_WITH(system, AC_HELP_STRING([--with-system=SYSTEM],
    [Platform identifier (e.g., `i686-linux').]),
    [guix_system="$withval"],
    [case "$host_cpu" in
       i*86)
	  machine_name="i686";;
       amd64)
          machine_name="x86_64";;
       arm|armv[[7-9]]*)
          # Here we want to exclude CPUs such as "armv6l".  On ARMv7
          # machines, we normally get "armv7l".  However, in Guix, we
          # configure with --build=arm-unknown-linux-gnueabihf, leading
          # to just "arm", so we also have to allow it.
          #
          # TODO: If not cross-compiling, add a sanity check to make
          #       sure this build machine has the needed features to
          #       support executables compiled using our armhf gcc,
          #       configured with:
          #         --with-arch=armv7-a
          #         --with-float=hard
          #         --with-mode=thumb
          #         --with-fpu=vfpv3-d16
	  machine_name="armhf";;
       *)
	  machine_name="$host_cpu";;
     esac

     case "$host_os" in
       linux-gnu*)
	  # For backward compatibility, strip the `-gnu' part.
	  guix_system="$machine_name-linux";;
       gnu*)
          # Always use i586 for GNU/Hurd.
          guix_system="i586-gnu";;
       *)
	  # Strip the version number from names such as `gnu0.3',
	  # `darwin10.2.0', etc.
	  guix_system="$machine_name-`echo $host_os | "$SED" -e's/[0-9.]*$//g'`";;
     esac])

  AC_MSG_CHECKING([for the Guix system type])
  AC_MSG_RESULT([$guix_system])

  AC_SUBST([guix_system])
])

dnl GUIX_ASSERT_SUPPORTED_SYSTEM
dnl
dnl Assert that this is a system to which the distro is ported.
AC_DEFUN([GUIX_ASSERT_SUPPORTED_SYSTEM], [
  AC_REQUIRE([GUIX_SYSTEM_TYPE])

  AC_ARG_WITH([courage], [AC_HELP_STRING([--with-courage],
    [Assert that even if this platform is unsupported, you will be
courageous and port the GNU System distribution to it (see
"GNU Distribution" in the manual.)])],
    [guix_courageous="$withval"],
    [guix_courageous="no"])

  # Currently only Linux-based systems are supported, and only on some
  # platforms.
  case "$guix_system" in
    x86_64-linux|i686-linux|armhf-linux|aarch64-linux|mips64el-linux)
      ;;
    *)
      if test "x$guix_courageous" = "xyes"; then
        AC_MSG_WARN([building Guix on `$guix_system', which is not supported])
      else
        AC_MSG_ERROR([`$guix_system' is not a supported platform.
See "GNU Distribution" in the manual, or try `--with-courage'.])
      fi
      ;;
  esac
])

dnl GUIX_ASSERT_GUILE_FEATURES FEATURES
dnl
dnl Assert that FEATURES are provided by $GUILE.
AC_DEFUN([GUIX_ASSERT_GUILE_FEATURES], [
  for guix_guile_feature in $1
  do
    AC_MSG_CHECKING([whether $GUILE provides feature '$guix_guile_feature'])
    if "$GUILE" -c "(exit (provided? '$guix_guile_feature))"
    then
      AC_MSG_RESULT([yes])
    else
      AC_MSG_RESULT([no])
      AC_MSG_ERROR([$GUILE does not support feature '$guix_guile_feature', which is required.])
    fi
  done
])

dnl GUIX_ASSERT_SYNTAX_OBJECT_EQUAL
dnl
dnl Guile 2.2.1 was a brown-paper-bag release where 'equal?' wouldn't work
dnl for syntax objects, which broke gexps.  Unfortunately Fedora 25 provides it.
dnl Reject it.
AC_DEFUN([GUIX_ASSERT_SYNTAX_OBJECT_EQUAL], [
  AC_CACHE_CHECK([whether 'equal?' works for syntax objects],
    [ac_cv_guix_syntax_object_equal],
    [if "$GUILE" -c '(exit (equal? (syntax x) (syntax x)))'
     then
       ac_cv_guix_syntax_object_equal=yes
     else
       ac_cv_guix_syntax_object_equal=no
     fi])
  if test "x$ac_cv_guix_syntax_object_equal" != xyes; then
    # This bug was present in Guile 2.2.1 only.
    AC_MSG_ERROR(['equal?' does not work for syntax object; upgrade to Guile 2.2.2 or later.])
  fi
])

dnl GUIX_CHECK_GUILE_SSH
dnl
dnl Check whether a recent-enough Guile-SSH is available.
AC_DEFUN([GUIX_CHECK_GUILE_SSH], [
  dnl Check whether 'channel-send-eof' (introduced in 0.10.2) is present.
  AC_CACHE_CHECK([whether Guile-SSH is available and recent enough],
    [guix_cv_have_recent_guile_ssh],
    [GUILE_CHECK([retval],
      [(and (@ (ssh channel) channel-send-eof)
            (@ (ssh popen) open-remote-pipe)
	    (@ (ssh dist node) node-eval))])
     if test "$retval" = 0; then
       guix_cv_have_recent_guile_ssh="yes"
     else
       guix_cv_have_recent_guile_ssh="no"
     fi])
])

dnl GUIX_CHECK_GUILE_SQLITE3
dnl
dnl Check whether a recent-enough Guile-Sqlite3 is available.
AC_DEFUN([GUIX_CHECK_GUILE_SQLITE3], [
  dnl Check whether 'sqlite-bind-arguments' is available.  It was introduced
  dnl in February 2018:
  dnl <https://notabug.org/civodul/guile-sqlite3/commit/1cd1dec96a9999db48c0ff45bab907efc637247f>.
  AC_CACHE_CHECK([whether Guile-Sqlite3 is available and recent enough],
    [guix_cv_have_recent_guile_sqlite3],
    [GUILE_CHECK([retval],
      [(@ (sqlite3) sqlite-bind-arguments)])
     if test "$retval" = 0; then
       guix_cv_have_recent_guile_sqlite3="yes"
     else
       guix_cv_have_recent_guile_sqlite3="no"
     fi])
])

dnl GUIX_TEST_ROOT_DIRECTORY
AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
  AC_CACHE_CHECK([for unit test root directory],
    [ac_cv_guix_test_root],
    [ac_cv_guix_test_root="`pwd`/test-tmp"])
])

dnl 'BINPRM_BUF_SIZE' constant in Linux (we leave room for the trailing zero.)
dnl The Hurd has a limit of about a page (see exec/hashexec.c.)
m4_define([LINUX_HASH_BANG_LIMIT], 127)

dnl Hardcoded 'sun_path' length in <sys/un.h>.
m4_define([SOCKET_FILE_NAME_LIMIT], 108)

dnl GUIX_SOCKET_FILE_NAME_LENGTH
AC_DEFUN([GUIX_SOCKET_FILE_NAME_LENGTH], [
  AC_CACHE_CHECK([the length of the installed socket file name],
    [ac_cv_guix_socket_file_name_length],
    [ac_cv_guix_socket_file_name_length="`echo -n "$guix_localstatedir/guix/daemon-socket/socket" | wc -c`"])
])

dnl GUIX_TEST_SOCKET_FILE_NAME_LENGTH
AC_DEFUN([GUIX_TEST_SOCKET_FILE_NAME_LENGTH], [
  AC_REQUIRE([GUIX_TEST_ROOT_DIRECTORY])
  AC_CACHE_CHECK([the length of the socket file name used in tests],
    [ac_cv_guix_test_socket_file_name_length],
    [ac_cv_guix_test_socket_file_name_length="`echo -n "$ac_cv_guix_test_root/var/123456/daemon-socket/socket" | wc -c`"])
])

dnl GUIX_HASH_BANG_LENGTH
AC_DEFUN([GUIX_HASH_BANG_LENGTH], [
  AC_CACHE_CHECK([the length of a typical hash bang line],
    [ac_cv_guix_hash_bang_length],
    [ac_cv_guix_hash_bang_length=`echo -n "$storedir/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bootstrap-binaries-0/bin/bash" | wc -c`])
])

dnl GUIX_TEST_HASH_BANG_LENGTH
AC_DEFUN([GUIX_TEST_HASH_BANG_LENGTH], [
  AC_REQUIRE([GUIX_TEST_ROOT_DIRECTORY])
  AC_CACHE_CHECK([the length of a hash bang line used in tests],
    [ac_cv_guix_test_hash_bang_length],
    [ac_cv_guix_test_hash_bang_length=`echo -n "$ac_cv_guix_test_root/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bootstrap-binaries-0/bin/bash" | wc -c`])
])

dnl GUIX_CHECK_FILE_NAME_LIMITS
dnl
dnl GNU/Linux has a couple of silly limits that we can easily run into.
dnl Make sure everything is fine with the current settings.  Set $1 to
dnl 'yes' if tests can run, 'no' otherwise.
AC_DEFUN([GUIX_CHECK_FILE_NAME_LIMITS], [
  AC_REQUIRE([GUIX_SOCKET_FILE_NAME_LENGTH])
  AC_REQUIRE([GUIX_TEST_SOCKET_FILE_NAME_LENGTH])
  AC_REQUIRE([GUIX_HASH_BANG_LENGTH])
  AC_REQUIRE([GUIX_TEST_HASH_BANG_LENGTH])

  if test "$ac_cv_guix_socket_file_name_length" -ge ]SOCKET_FILE_NAME_LIMIT[; then
    AC_MSG_ERROR([socket file name would exceed the maxium allowed length])
  fi
  if test "$ac_cv_guix_test_socket_file_name_length" -ge ]SOCKET_FILE_NAME_LIMIT[; then
    AC_MSG_WARN([socket file name limit may be exceeded when running tests])
  fi

  $1=yes
  if test "$ac_cv_guix_hash_bang_length" -ge ]LINUX_HASH_BANG_LIMIT[; then
    $1=no
    AC_MSG_ERROR([store directory '$storedir' would lead to overly long hash-bang lines])
  fi
  if test "$ac_cv_guix_test_hash_bang_length" -ge ]LINUX_HASH_BANG_LIMIT[; then
    $1=no
    AC_MSG_WARN([test directory '$ac_cv_guix_test_root' may lead to overly long hash-bang lines])
  fi
])

dnl GUIX_CHECK_CXX11
dnl
dnl Check whether the C++ compiler can compile a typical C++11 program.
AC_DEFUN([GUIX_CHECK_CXX11], [
  AC_REQUIRE([AC_PROG_CXX])
  AC_CACHE_CHECK([whether $CXX supports C++11],
    [ac_cv_guix_cxx11_support],
    [save_CXXFLAGS="$CXXFLAGS"
     CXXFLAGS="-std=c++11 $CXXFLAGS"
     AC_COMPILE_IFELSE([
      AC_LANG_SOURCE([
	#include <functional>

	std::function<int(int)>
	return_plus_lambda (int x)
	{
	  auto result = [[&]](int y) {
	    return x + y;
	  };

	  return result;
	}
      ])],
      [ac_cv_guix_cxx11_support=yes],
      [ac_cv_guix_cxx11_support=no])
    CXXFLAGS="$save_CXXFLAGS"
  ])
])

dnl GUIX_ASSERT_CXX11
dnl
dnl Error out if the C++ compiler cannot compile C++11 code.
AC_DEFUN([GUIX_ASSERT_CXX11], [
  GUIX_CHECK_CXX11
  if test "x$ac_cv_guix_cxx11_support" != "xyes"; then
    AC_MSG_ERROR([C++ compiler '$CXX' does not support the C++11 standard])
  fi
])

dnl GUIX_LIBGCRYPT_LIBDIR VAR
dnl
dnl Attempt to determine libgcrypt's LIBDIR; store the result in VAR.
AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [
  AC_PATH_PROG([LIBGCRYPT_CONFIG], [libgcrypt-config])
  AC_CACHE_CHECK([libgcrypt's library directory],
    [guix_cv_libgcrypt_libdir],
    [if test "x$LIBGCRYPT_CONFIG" != "x"; then
       guix_cv_libgcrypt_libdir=`$LIBGCRYPT_CONFIG --libs | grep -e -L | sed -e "s/.*-L\([[^ ]]\+\)[[[:blank:]]]\+-lgcrypt.*/\1/g"`
     else
       guix_cv_libgcrypt_libdir=""
     fi])
  $1="$guix_cv_libgcrypt_libdir"
])

dnl GUIX_LIBZ_LIBDIR VAR
dnl
dnl Attempt to determine libz's LIBDIR; store the result in VAR.
AC_DEFUN([GUIX_LIBZ_LIBDIR], [
  AC_REQUIRE([PKG_PROG_PKG_CONFIG])
  AC_CACHE_CHECK([zlib's library directory],
    [guix_cv_libz_libdir],
    [guix_cv_libz_libdir="`$PKG_CONFIG zlib --variable=libdir 2> /dev/null`"])
  $1="$guix_cv_libz_libdir"
])

dnl GUIX_CURRENT_LOCALSTATEDIR
dnl
dnl Determine the localstatedir of an existing Guix installation and set
dnl 'guix_cv_current_localstatedir' accordingly.  Set it to "none" if no
dnl existing installation was found.
AC_DEFUN([GUIX_CURRENT_LOCALSTATEDIR], [
  AC_PATH_PROG([GUILE], [guile])
  AC_CACHE_CHECK([the current installation's localstatedir],
    [guix_cv_current_localstatedir],
    [dnl Call 'dirname' because (guix config) appends "/guix" to LOCALSTATEDIR.
     guix_cv_current_localstatedir="`"$GUILE" \
       -c '(use-modules (guix config))
           (when (string=? %store-directory "'$storedir'")
             (display (dirname %state-directory)))' \
       2>/dev/null`"
     if test "x$guix_cv_current_localstatedir" = "x"; then
       guix_cv_current_localstatedir=none
     fi])])

dnl GUIX_CHECK_LOCALSTATEDIR
dnl
dnl Check that the LOCALSTATEDIR value is consistent with that of the existing
dnl Guix installation, if any.  Error out or warn if they do not match.
AC_DEFUN([GUIX_CHECK_LOCALSTATEDIR], [
  AC_REQUIRE([GUIX_CURRENT_LOCALSTATEDIR])
  if test "x$guix_cv_current_localstatedir" != "xnone"; then
    if test "$guix_cv_current_localstatedir" != "$guix_localstatedir"; then
      case "$localstatedir" in
        NONE|\${prefix}*)
          # User kept the default value---i.e., did not pass '--localstatedir'.
          AC_MSG_ERROR([chosen localstatedir '$guix_localstatedir' does not match \
that of the existing installation '$guix_cv_current_localstatedir'
Installing may corrupt $storedir!
Use './configure --localstatedir=$guix_cv_current_localstatedir'.])
          ;;
        *)
          # User passed an explicit '--localstatedir'.  Assume they know what
          # they're doing.
          AC_MSG_WARN([chosen localstatedir '$guix_localstatedir' does not match \
that of the existing installation '$guix_cv_current_localstatedir'])
          AC_MSG_WARN([installing may corrupt $storedir!])
         ;;
      esac
    fi
  fi])


code:
Most of the code is this directory was written by several people for
the Nix project (http://nixos.org/nix).  Thanks!

path: nix/AUTHORS


code:
//
//  boost/assert.hpp - BOOST_ASSERT(expr)
//
//  Copyright (c) 2001, 2002 Peter Dimov and Multi Media Ltd.
//
//  Permission to copy, use, modify, sell and distribute this software
//  is granted provided this copyright notice appears in all copies.
//  This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.
//
//  Note: There are no include guards. This is intentional.
//
//  See http://www.boost.org/libs/utility/assert.html for documentation.
//

#undef BOOST_ASSERT

#if defined(BOOST_DISABLE_ASSERTS)

# define BOOST_ASSERT(expr) ((void)0)

#elif defined(BOOST_ENABLE_ASSERT_HANDLER)

#include <boost/current_function.hpp>

namespace boost
{

void assertion_failed(char const * expr, char const * function, char const * file, long line); // user defined

} // namespace boost

#define BOOST_ASSERT(expr) ((expr)? ((void)0): ::boost::assertion_failed(#expr, BOOST_CURRENT_FUNCTION, __FILE__, __LINE__))

#else
# include <assert.h>
# define BOOST_ASSERT(expr) assert(expr)
#endif


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream

// ----------------------------------------------------------------------------
// format.hpp :  primary header
// ----------------------------------------------------------------------------

#ifndef BOOST_FORMAT_HPP
#define BOOST_FORMAT_HPP

#include <vector>
#include <string>
#include <sstream>
#include <cassert>

#if HAVE_LOCALE
#include <locale>
#else
#define BOOST_NO_STD_LOCALE
#define BOOST_NO_LOCALE_ISIDIGIT
#include <cctype>
#endif

#include <boost/format/macros_default.hpp>

// ****  Forward declarations ----------------------------------
#include <boost/format/format_fwd.hpp>           // basic_format<Ch,Tr>, and other frontends
#include <boost/format/internals_fwd.hpp>        // misc forward declarations for internal use

// ****  Auxiliary structs (stream_format_state<Ch,Tr> , and format_item<Ch,Tr> )
#include <boost/format/internals.hpp>

// ****  Format  class  interface --------------------------------
#include <boost/format/format_class.hpp>

// **** Exceptions -----------------------------------------------
#include <boost/format/exceptions.hpp>

// **** Implementation -------------------------------------------
//#include <boost/format/format_implementation.hpp>   // member functions

#include <boost/format/group.hpp>                   // class for grouping arguments

#include <boost/format/feed_args.hpp>               // argument-feeding functions
//#include <boost/format/parsing.hpp>                 // format-string parsing (member-)functions

// **** Implementation of the free functions ----------------------
//#include <boost/format/free_funcs.hpp>

#endif // BOOST_FORMAT_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream (also took its parsing code as basis for printf parsing)

// ------------------------------------------------------------------------------
// exceptions.hpp
// ------------------------------------------------------------------------------

#ifndef BOOST_FORMAT_EXCEPTIONS_HPP
#define BOOST_FORMAT_EXCEPTIONS_HPP

#include <stdexcept>

namespace boost {

namespace io {

// **** exceptions -----------------------------------------------

class format_error : public std::exception
{
public:
  format_error() {}
  virtual const char *what() const throw()
  {
    return "boost::format_error: "
      "format generic failure";
  }
};

class bad_format_string : public format_error
{
public:
  bad_format_string() {}
  virtual const char *what() const throw()
  {
    return "boost::bad_format_string: "
      "format-string is ill-formed";
  }
};

class too_few_args : public format_error
{
public:
  too_few_args() {}
  virtual const char *what() const throw()
  {
    return "boost::too_few_args: "
      "format-string refered to more arguments than were passed";
  }
};

class too_many_args : public format_error
{
public:
  too_many_args() {}
  virtual const char *what() const throw()
  {
    return "boost::too_many_args: "
      "format-string refered to less arguments than were passed";
  }
};

class  out_of_range : public format_error
{
public:
  out_of_range() {}
  virtual const char *what() const throw()
  {
    return "boost::out_of_range: "
      "tried to refer to an argument (or item) number which is out of range, "
      "according to the format string.";
  }
};

} // namespace io

} // namespace boost

#endif // BOOST_FORMAT_EXCEPTIONS_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream

// ----------------------------------------------------------------------------
// feed_args.hpp :  functions for processing each argument
//                      (feed, feed_manip, and distribute)
// ----------------------------------------------------------------------------

#ifndef BOOST_FORMAT_FEED_ARGS_HPP
#define BOOST_FORMAT_FEED_ARGS_HPP

#include "boost/format/format_class.hpp"
#include "boost/format/group.hpp"

#include "boost/throw_exception.hpp"

namespace boost {
namespace io {
namespace detail {
namespace  {

  inline
  void empty_buf(BOOST_IO_STD ostringstream & os) {
    static const std::string emptyStr;
    os.str(emptyStr);
  }

  void do_pad( std::string & s,
                std::streamsize w,
                const char c,
                std::ios::fmtflags f,
                bool center)
    // applies centered / left / right  padding  to the string s.
    // Effects : string s is padded.
  {
    std::streamsize n=w-s.size();
    if(n<=0) {
      return;
    }
    if(center)
      {
        s.reserve(w); // allocate once for the 2 inserts
        const std::streamsize n1 = n /2, n0 = n - n1;
        s.insert(s.begin(), n0, c);
        s.append(n1, c);
      }
    else
      {
        if(f & std::ios::left) {
          s.append(n, c);
        }
        else {
          s.insert(s.begin(), n, c);
        }
      }
  } // -do_pad(..)

  template<class T> inline
  void put_head(BOOST_IO_STD ostream& , const T& ) {
  }

  template<class T> inline
  void put_head( BOOST_IO_STD ostream& os, const group1<T>& x ) {
    os << group_head(x.a1_); // send the first N-1 items, not the last
  }

  template<class T> inline
  void put_last( BOOST_IO_STD ostream& os, const T& x ) {
    os << x ;
  }

  template<class T> inline
  void put_last( BOOST_IO_STD ostream& os, const group1<T>& x ) {
    os << group_last(x.a1_); // this selects the last element
  }

#ifndef BOOST_NO_OVERLOAD_FOR_NON_CONST
  template<class T> inline
  void put_head( BOOST_IO_STD ostream& , T& ) {
  }

  template<class T> inline
  void put_last( BOOST_IO_STD ostream& os, T& x ) {
    os << x ;
  }
#endif

template<class T>
void put( T x,
          const format_item& specs,
          std::string & res,
          BOOST_IO_STD ostringstream& oss_ )
{
  // does the actual conversion of x, with given params, into a string
  // using the *supplied* strinstream. (the stream state is important)

  typedef std::string string_t;
  typedef format_item  format_item_t;

  stream_format_state   prev_state(oss_);

  specs.state_.apply_on(oss_);

  // in case x is a group, apply the manip part of it,
  // in order to find width
  put_head( oss_, x );
  empty_buf( oss_);

  const std::streamsize w=oss_.width();
  const std::ios::fmtflags fl=oss_.flags();
  const bool internal = (fl & std::ios::internal) != 0;
  const bool two_stepped_padding = internal
    &&  ! ( specs.pad_scheme_ & format_item_t::spacepad )
    && specs.truncate_ < 0 ;

  if(! two_stepped_padding)
    {
      if(w>0) // handle simple padding via do_pad, not natively in stream
        oss_.width(0);
      put_last( oss_, x);
      res = oss_.str();

      if (specs.truncate_ >= 0)
        res.erase(specs.truncate_);

      // complex pads :
      if(specs.pad_scheme_ & format_item_t::spacepad)
        {
          if( res.size()==0 ||   ( res[0]!='+' && res[0]!='-'  ))
            {
              res.insert(res.begin(), 1, ' '); // insert 1 space at  pos 0
            }
        }
      if(w > 0) // need do_pad
        {
          do_pad(res,w,oss_.fill(), fl, (specs.pad_scheme_ & format_item_t::centered) !=0 );
        }
    }
  else  // 2-stepped padding
    {
      put_last( oss_, x); // oss_.width() may result in padding.
      res = oss_.str();

      if (specs.truncate_ >= 0)
        res.erase(specs.truncate_);

      if( res.size() - w > 0)
        { //   length w exceeded
          // either it was multi-output with first output padding up all width..
          // either it was one big arg and we are fine.
          empty_buf( oss_);
          oss_.width(0);
          put_last(oss_, x );
          string_t tmp = oss_.str();  // minimal-length output
          std::streamsize d;
          if( (d=w - tmp.size()) <=0 )
            {
              // minimal length is already >= w, so no padding  (cool!)
              res.swap(tmp);
            }
          else
            { // hum..  we need to pad (it was necessarily multi-output)
              typedef typename string_t::size_type size_type;
              size_type i = 0;
              while( i<tmp.size() && tmp[i] == res[i] ) // find where we should pad.
                ++i;
              tmp.insert(i, static_cast<size_type>( d ), oss_.fill());
              res.swap( tmp );
            }
        }
      else
        { // okay, only one thing was printed and padded, so res is fine.
        }
    }

  prev_state.apply_on(oss_);
  empty_buf( oss_);
  oss_.clear();
} // end- put(..)

}  // local namespace

template<class T>
void distribute(basic_format& self, T x)
  // call put(x, ..) on every occurence of the current argument :
{
  if(self.cur_arg_ >= self.num_args_)
    {
      if( self.exceptions() & too_many_args_bit )
        boost::throw_exception(too_many_args()); // too many variables have been supplied !
      else return;
    }
  for(unsigned long i=0; i < self.items_.size(); ++i)
    {
      if(self.items_[i].argN_ == self.cur_arg_)
        {
          put<T> (x, self.items_[i], self.items_[i].res_, self.oss_ );
        }
    }
}

template<class T>
basic_format&  feed(basic_format& self, T x)
{
  if(self.dumped_) self.clear();
  distribute<T> (self, x);
  ++self.cur_arg_;
  if(self.bound_.size() != 0)
    {
      while( self.cur_arg_ < self.num_args_ && self.bound_[self.cur_arg_] )
        ++self.cur_arg_;
    }

  // this arg is finished, reset the stream's format state
  self.state0_.apply_on(self.oss_);
  return self;
}

} // namespace detail
} // namespace io
} // namespace boost

#endif //  BOOST_FORMAT_FEED_ARGS_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream (also took its parsing code as basis for printf parsing)

// ------------------------------------------------------------------------------
// format_class.hpp :  class interface
// ------------------------------------------------------------------------------

#ifndef BOOST_FORMAT_CLASS_HPP
#define BOOST_FORMAT_CLASS_HPP

#include <vector>
#include <string>

#include <boost/format/format_fwd.hpp>
#include <boost/format/internals_fwd.hpp>

#include <boost/format/internals.hpp>

namespace boost {

class basic_format
{
public:
  typedef std::string                string_t;
  typedef BOOST_IO_STD ostringstream internal_stream_t;
private:
  typedef BOOST_IO_STD ostream       stream_t;
  typedef io::detail::stream_format_state  stream_format_state;
  typedef io::detail::format_item          format_item_t;

public:
  basic_format(const char* str);
  basic_format(const string_t& s);
#ifndef BOOST_NO_STD_LOCALE
  basic_format(const char* str, const std::locale & loc);
  basic_format(const string_t& s, const std::locale & loc);
#endif // no locale
  basic_format(const basic_format& x);
  basic_format& operator= (const basic_format& x);

  basic_format& clear(); // empty the string buffers (except bound arguments, see clear_binds() )

  // pass arguments through those operators :
  template<class T>  basic_format&   operator%(const T& x)
  {
    return io::detail::feed<const T&>(*this,x);
  }

#ifndef BOOST_NO_OVERLOAD_FOR_NON_CONST
  template<class T>  basic_format&   operator%(T& x)
  {
    return io::detail::feed<T&>(*this,x);
  }
#endif

  // system for binding arguments :
  template<class T>
  basic_format&         bind_arg(int argN, const T& val)
  {
    return io::detail::bind_arg_body(*this, argN, val);
  }
  basic_format&         clear_bind(int argN);
  basic_format&         clear_binds();

  // modify the params of a directive, by applying a manipulator :
  template<class T>
  basic_format&  modify_item(int itemN, const T& manipulator)
  {
    return io::detail::modify_item_body(*this, itemN, manipulator) ;
  }

  // Choosing which errors will throw exceptions :
  unsigned char exceptions() const;
  unsigned char exceptions(unsigned char newexcept);

  // final output
  string_t str() const;
  friend BOOST_IO_STD ostream&
  operator<< ( BOOST_IO_STD ostream& , const basic_format& );

  template<class T>  friend basic_format&
  io::detail::feed(basic_format&, T);

  template<class T>  friend
  void io::detail::distribute(basic_format&, T);

  template<class T>  friend
  basic_format&  io::detail::modify_item_body(basic_format&, int, const T&);

  template<class T> friend
  basic_format&  io::detail::bind_arg_body(basic_format&, int, const T&);

// make the members private only if the friend templates are supported
private:

  // flag bits, used for style_
  enum style_values  { ordered = 1,        // set only if all directives are  positional directives
                       special_needs = 4 };

  // parse the format string :
  void parse(const string_t&);

  int                           style_;         // style of format-string :  positional or not, etc
  int                           cur_arg_;       // keep track of wich argument will come
  int                           num_args_;      // number of expected arguments
  mutable bool                  dumped_;        // true only after call to str() or <<
  std::vector<format_item_t>    items_;         // vector of directives (aka items)
  string_t                      prefix_;        // piece of string to insert before first item

  std::vector<bool>             bound_;         // stores which arguments were bound
                                                //   size = num_args OR zero
  internal_stream_t             oss_;           // the internal stream.
  stream_format_state           state0_;        // reference state for oss_
  unsigned char                 exceptions_;
}; // class basic_format

} // namespace boost

#endif // BOOST_FORMAT_CLASS_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream (also took its parsing code as basis for printf parsing)

// ------------------------------------------------------------------------------
// format_fwd.hpp :  forward declarations, for primary header format.hpp
// ------------------------------------------------------------------------------

#ifndef BOOST_FORMAT_FWD_HPP
#define BOOST_FORMAT_FWD_HPP

#include <string>
#include <iosfwd>

namespace boost {

class basic_format;

typedef basic_format    format;

namespace io {
enum format_error_bits { bad_format_string_bit = 1,
                         too_few_args_bit = 2, too_many_args_bit = 4,
                         out_of_range_bit = 8,
                         all_error_bits = 255, no_error_bits=0 };

// Convertion:  format   to   string
std::string     str(const basic_format& ) ;

} // namespace io

BOOST_IO_STD ostream&
operator<<( BOOST_IO_STD ostream&, const basic_format&);

} // namespace boost

#endif // BOOST_FORMAT_FWD_HPP


code:
// -*- C++ -*-
//  Boost general library format ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream

// ----------------------------------------------------------------------------
// format_implementation.hpp  Implementation of the basic_format class
// ----------------------------------------------------------------------------

#ifndef BOOST_FORMAT_IMPLEMENTATION_HPP
#define BOOST_FORMAT_IMPLEMENTATION_HPP

#include <boost/throw_exception.hpp>
#include <boost/assert.hpp>
#include <boost/format.hpp>

namespace boost {

// --------  format:: -------------------------------------------
basic_format::basic_format(const char* str)
    : style_(0), cur_arg_(0), num_args_(0), dumped_(false),
      items_(), oss_(), exceptions_(io::all_error_bits)
{
    state0_.set_by_stream(oss_);
    string_t emptyStr;
    if( !str) str = emptyStr.c_str();
    parse( str );
}

#ifndef BOOST_NO_STD_LOCALE
basic_format::basic_format(const char* str, const std::locale & loc)
    : style_(0), cur_arg_(0), num_args_(0), dumped_(false),
      items_(), oss_(), exceptions_(io::all_error_bits)
{
    oss_.imbue( loc );
    state0_.set_by_stream(oss_);
    string_t emptyStr;
    if( !str) str = emptyStr.c_str();
    parse( str );
}

basic_format::basic_format(const string_t& s, const std::locale & loc)
    : style_(0), cur_arg_(0), num_args_(0), dumped_(false),
      items_(),  oss_(), exceptions_(io::all_error_bits)
{
    oss_.imbue( loc );
    state0_.set_by_stream(oss_);
    parse(s);
}
#endif //BOOST_NO_STD_LOCALE

basic_format::basic_format(const string_t& s)
    : style_(0), cur_arg_(0), num_args_(0), dumped_(false),
      items_(),  oss_(), exceptions_(io::all_error_bits)
{
    state0_.set_by_stream(oss_);
    parse(s);
}

basic_format:: basic_format(const basic_format& x)
    : style_(x.style_), cur_arg_(x.cur_arg_), num_args_(x.num_args_), dumped_(false),
      items_(x.items_), prefix_(x.prefix_), bound_(x.bound_),
      oss_(),   // <- we obviously can't copy x.oss_
      state0_(x.state0_), exceptions_(x.exceptions_)
{
    state0_.apply_on(oss_);
}

basic_format& basic_format::operator= (const basic_format& x)
{
    if(this == &x)
      return *this;
    state0_ = x.state0_;
    state0_.apply_on(oss_);

    // plus all the other (trivial) assignments :
    exceptions_ = x.exceptions_;
    items_ = x.items_;
    prefix_ = x.prefix_;
    bound_=x.bound_;
    style_=x.style_;
    cur_arg_=x.cur_arg_;
    num_args_=x.num_args_;
    dumped_=x.dumped_;
    return *this;
}

unsigned char basic_format::exceptions() const
{
  return exceptions_;
}

unsigned char basic_format::exceptions(unsigned char newexcept)
{
  unsigned char swp = exceptions_;
  exceptions_ = newexcept;
  return swp;
}

basic_format& basic_format ::clear()
  // empty the string buffers (except bound arguments, see clear_binds() )
  // and make the format object ready for formatting a new set of arguments
{
    BOOST_ASSERT( bound_.size()==0 || num_args_ == static_cast<int>(bound_.size()) );

    for(unsigned long i=0; i<items_.size(); ++i){
      items_[i].state_ = items_[i].ref_state_;
      // clear converted strings only if the corresponding argument is not  bound :
      if( bound_.size()==0 || !bound_[ items_[i].argN_ ] )  items_[i].res_.resize(0);
    }
    cur_arg_=0; dumped_=false;
    // maybe first arg is bound:
    if(bound_.size() != 0)
      {
        while(cur_arg_ < num_args_ && bound_[cur_arg_] )      ++cur_arg_;
      }
    return *this;
}

basic_format& basic_format ::clear_binds()
  // cancel all bindings, and clear()
{
    bound_.resize(0);
    clear();
    return *this;
}

basic_format& basic_format::clear_bind(int argN)
  // cancel the binding of ONE argument, and clear()
{
    if(argN<1 || argN > num_args_ || bound_.size()==0 || !bound_[argN-1] )
      {
        if( exceptions() & io::out_of_range_bit )
          boost::throw_exception(io::out_of_range()); // arg not in range.
        else return *this;
      }
    bound_[argN-1]=false;
    clear();
    return *this;
}

std::string basic_format::str() const
{
  dumped_=true;
  if(items_.size()==0)
    return prefix_;
  if( cur_arg_ < num_args_)
      if( exceptions() & io::too_few_args_bit )
        boost::throw_exception(io::too_few_args()); // not enough variables have been supplied !

  unsigned long sz = prefix_.size();
  unsigned long i;
  for(i=0; i < items_.size(); ++i)
    sz += items_[i].res_.size() + items_[i].appendix_.size();
  string_t res;
  res.reserve(sz);

  res += prefix_;
  for(i=0; i < items_.size(); ++i)
  {
    const format_item_t& item = items_[i];
    res += item.res_;
    if( item.argN_ == format_item_t::argN_tabulation)
    {
      BOOST_ASSERT( item.pad_scheme_ & format_item_t::tabulation);
      std::streamsize  n = item.state_.width_ - res.size();
      if( n > 0 )
        res.append( n, item.state_.fill_ );
    }
    res += item.appendix_;
  }
  return res;
}

namespace io {
namespace detail {

template<class T>
basic_format&  bind_arg_body( basic_format& self,
                                      int argN,
                                      const T& val)
  // bind one argument to a fixed value
  // this is persistent over clear() calls, thus also over str() and <<
{
    if(self.dumped_) self.clear(); // needed, because we will modify cur_arg_..
    if(argN<1 || argN > self.num_args_)
      {
        if( self.exceptions() & io::out_of_range_bit )
          boost::throw_exception(io::out_of_range()); // arg not in range.
        else return self;
      }
    if(self.bound_.size()==0)
      self.bound_.assign(self.num_args_,false);
    else
      BOOST_ASSERT( self.num_args_ == static_cast<signed int>(self.bound_.size()) );
    int o_cur_arg = self.cur_arg_;
    self.cur_arg_ = argN-1; // arrays begin at 0

    self.bound_[self.cur_arg_]=false; // if already set, we unset and re-sets..
    self.operator%(val); // put val at the right place, because cur_arg is set

    // Now re-position cur_arg before leaving :
    self.cur_arg_ = o_cur_arg;
    self.bound_[argN-1]=true;
    if(self.cur_arg_ == argN-1 )
      // hum, now this arg is bound, so move to next free arg
      {
        while(self.cur_arg_ < self.num_args_ && self.bound_[self.cur_arg_])   ++self.cur_arg_;
      }
    // In any case, we either have all args, or are on a non-binded arg :
    BOOST_ASSERT( self.cur_arg_ >= self.num_args_ || ! self.bound_[self.cur_arg_]);
    return self;
}

template<class T>
basic_format&  modify_item_body( basic_format& self,
                                      int itemN,
                                      const T& manipulator)
  // applies a manipulator to the format_item describing a given directive.
  // this is a permanent change, clear or clear_binds won't cancel that.
{
  if(itemN<1 || itemN >= static_cast<signed int>(self.items_.size() ))
    {
      if( self.exceptions() & io::out_of_range_bit )
        boost::throw_exception(io::out_of_range()); // item not in range.
      else return self;
    }
  self.items_[itemN-1].ref_state_.apply_manip( manipulator );
  self.items_[itemN-1].state_ = self.items_[itemN-1].ref_state_;
  return self;
}

} // namespace detail

} // namespace io

} // namespace boost

#endif  // BOOST_FORMAT_IMPLEMENTATION_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream (also took its parsing code as basis for printf parsing)

// ------------------------------------------------------------------------------
// free_funcs.hpp :  implementation of the free functions declared in namespace format
// ------------------------------------------------------------------------------

#ifndef BOOST_FORMAT_FUNCS_HPP
#define BOOST_FORMAT_FUNCS_HPP

#include "boost/format.hpp"
#include "boost/throw_exception.hpp"

namespace boost {

namespace io {
  inline
  std::string str(const basic_format& f)
    // adds up all pieces of strings and converted items, and return the formatted string
  {
    return f.str();
  }
}   // - namespace io

BOOST_IO_STD ostream&
operator<<( BOOST_IO_STD ostream& os,
            const boost::basic_format& f)
  // effect: "return os << str(f);" but we can try to do it faster
{
  typedef boost::basic_format   format_t;
  if(f.items_.size()==0)
    os << f.prefix_;
  else {
    if(f.cur_arg_ < f.num_args_)
      if( f.exceptions() & io::too_few_args_bit )
        boost::throw_exception(io::too_few_args()); // not enough variables have been supplied !
    if(f.style_ & format_t::special_needs)
        os << f.str();
    else {
    // else we dont have to count chars output, so we dump directly to os :
      os << f.prefix_;
      for(unsigned long i=0; i<f.items_.size(); ++i)
        {
          const format_t::format_item_t& item = f.items_[i];
          os << item.res_;
          os << item.appendix_;

        }
    }
  }
  f.dumped_=true;
  return os;
}

} // namespace boost

#endif // BOOST_FORMAT_FUNCS_HPP