~whereiseveryone/guixrus

b8e7fde894f1b04638c224fb3c27bd0e2b235335 — Julien Lepiller 2 years ago a7a505c composer
build-systems: Add composer-build-system
A guixrus/build-systems/composer-build-system.scm => guixrus/build-systems/composer-build-system.scm +224 -0
@@ 0,0 1,224 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 (guixrus build-systems composer-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build json)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            composer-build))

;; Commentary:
;;
;; Builder-side code of the standard composer build procedure.
;;
;; Code:

(define* (read-package-data #:key (filename "composer.json"))
  (call-with-input-file filename
    (lambda (port)
      (read-json port))))

(define* (check #:key composer-file inputs outputs tests? test-target #:allow-other-keys)
  "Install the given package."
  (when tests?
    (mkdir-p "vendor")
    (create-autoload (string-append (getcwd) "/vendor") composer-file
                     (append inputs outputs) #:dev-dependencies? #t)
    (let* ((package-data (read-package-data #:filename composer-file))
           (scripts (match (assoc-ref package-data "scripts")
                      (('@ script ...) script)
                      (#f '())))
           (test-script
             (assoc-ref scripts test-target))
           (dependencies (filter (lambda (dep) (string-contains dep "/"))
                                 (map car
                                      (match (assoc-ref package-data "require")
                                        (('@ dependency ...) dependency)
                                        (#f '())))))
           (dependencies-dev
             (filter (lambda (dep) (string-contains dep "/"))
                     (map car
                          (match (assoc-ref package-data "require-dev")
                            (('@ dependency ...) dependency)
                            (#f '())))))
           (name (assoc-ref package-data "name")))
      (for-each
        (lambda (input)
          (let ((bin (find-php-bin (cdr input))))
            (when bin
              (copy-recursively bin "vendor/bin"))))
        inputs)
      (match test-script
        ((? string? command)
         (unless (equal? (system command) 0)
           (throw 'failed-command command)))
        (('@ (? string? command) ...)
         (for-each
           (lambda (c)
             (unless (equal? (system c) 0)
               (throw 'failed-command c)))
           command))
        (#f (invoke "vendor/bin/phpunit")))))
  #t)

(define (find-php-bin input)
  (let* ((web-dir (string-append input "/share/web"))
         (vendors (if (file-exists? web-dir)
                      (find-files web-dir "^vendor$" #:directories? #t)
                      #f)))
    (match vendors
      ((vendor)
       (let ((bin (string-append vendor "/bin")))
         (and (file-exists? bin) bin)))
      (_ #f))))

(define (find-php-dep inputs dependency)
  (let loop ((inputs (map cdr inputs)))
    (if (null? inputs)
        (throw 'unsatisfied-dependency "Unsatisfied dependency: required " dependency)
        (let ((autoload (string-append (car inputs) "/share/web/" dependency "/vendor/autoload_conf.php")))
          (if (file-exists? autoload)
              autoload
              (loop (cdr inputs)))))))

(define* (create-autoload vendor composer-file inputs #:key dev-dependencies?)
  (with-output-to-file (string-append vendor "/autoload.php")
    (lambda _
      (format #t "<?php~%")
      (format #t "// autoload.php @generated by Guix~%")
      (format #t "$map = $psr4map = $classmap = array();~%")
      (format #t "require_once '~a/autoload_conf.php';~%" vendor)
      (format #t "require_once '~a/share/web/composer/ClassLoader.php';~%"
                 (assoc-ref inputs "composer-classloader"))
      (format #t "$loader = new \\Composer\\Autoload\\ClassLoader();~%")
      (format #t "foreach ($map as $namespace => $path) {~%")
      (format #t "  $loader->set($namespace, $path);~%")
      (format #t "}~%")
      (format #t "foreach ($psr4map as $namespace => $path) {~%")
      (format #t "  $loader->setPsr4($namespace, $path);~%")
      (format #t "}~%")
      (format #t "$loader->addClassMap($classmap);~%")
      (format #t "$loader->register();~%")))
  (let* ((package-data (read-package-data #:filename composer-file))
         (autoload
           (match (assoc-ref package-data "autoload")
             (('@ autoload ...) autoload)
             (#f '())))
         (autoload-dev
           (match (assoc-ref package-data "autoload-dev")
             (('@ autoload-dev ...) autoload-dev)
             (#f '())))
         (dependencies (filter (lambda (dep) (string-contains dep "/"))
                               (map car
                                    (match (assoc-ref package-data "require")
                                      (('@ dependency ...) dependency)
                                      (#f '())))))
         (dependencies-dev
           (filter (lambda (dep) (string-contains dep "/"))
                   (map car
                        (match (assoc-ref package-data "require-dev")
                          (('@ dependency ...) dependency)
                          (#f '()))))))
    (with-output-to-file (string-append vendor "/autoload_conf.php")
      (lambda _
        (format #t "<?php~%")
        (format #t "// autoload_conf.php @generated by Guix~%")
        (force-output)
        (for-each
          (lambda (psr4)
            (match psr4
              ((key . value)
               (format #t "$psr4map['~a'] = '~a/../~a';~%"
                       (string-join (string-split key #\\) "\\\\")
                       vendor value))))
          (append
            (match (assoc-ref autoload "psr-4")
              (('@ psr4 ...) psr4)
              (#f '()))
            (if dev-dependencies?
                (match (assoc-ref autoload-dev "psr-4")
                  (('@ psr4 ...) psr4)
                  (#f '()))
                '())))
        (for-each
          (lambda (classmap)
            (for-each
              (lambda (file)
                (invoke "php" (assoc-ref inputs "findclass.php")
                        "-i" (string-append vendor "/..") "-f" file))
              (find-files classmap ".(php|hh|inc)$")))
          (append
            (or (assoc-ref autoload "classmap") '())
            (if dev-dependencies?
                (or (assoc-ref autoload-dev "classmap") '())
                '())))
        (for-each
          (lambda (dep)
            (format #t "require_once '~a';~%" (find-php-dep inputs dep)))
          (append
            dependencies
            (if dev-dependencies?
                dependencies-dev
                '())))))))

(define* (install #:key inputs outputs composer-file #:allow-other-keys)
  "Install the given package."
  (let* ((out (assoc-ref outputs "out"))
         (package-data (read-package-data #:filename composer-file))
         (name (assoc-ref package-data "name"))
         (php-dir (string-append out "/share/web/" name))
         (bin-dir (string-append php-dir "/vendor/bin"))
         (bin (string-append out "/bin"))
         (binaries (assoc-ref package-data "bin")))
      (mkdir-p php-dir)
      (copy-recursively "." php-dir)
      (mkdir-p (string-append php-dir "/vendor"))
      (when binaries
        (mkdir-p bin-dir)
        (mkdir-p bin)
        (for-each
          (lambda (file)
            (let ((installed-file (string-append bin-dir "/" (basename file)))
                  (bin-file (string-append bin "/" (basename file)))
                  (original-file (string-append php-dir "/" file)))
              (symlink original-file installed-file)
              (symlink original-file bin-file)))
          binaries))
      (create-autoload (string-append php-dir "/vendor")
                       composer-file inputs))
  #t)

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; , `build', `check' and `install' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'build)
    (delete 'check)
    (replace 'install install)
    (add-after 'install 'check check)))

(define* (composer-build #:key inputs (phases %standard-phases)
                         #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; ocaml-build-system.scm ends here
\ No newline at end of file

A guixrus/build-systems/composer.scm => guixrus/build-systems/composer.scm +172 -0
@@ 0,0 1,172 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 (guixrus build-systems composer)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:use-module (ice-9 session)
  #:use-module (srfi srfi-1)
  #:export (%composer-build-system-modules
            lower
            composer-build
            composer-build-system))

;; Commentary:
;;
;; Standard build procedure for PHP packages using Composer. This is implemented
;; as an extension of `gnu-build-system'.
;;
;; Code:

(define (default-php)
  "Return the default PHP package."

  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(gnu packages php))))
    (module-ref module 'php)))

(define (default-findclass)
  "Return the default findclass script."
  (local-file (string-append (current-source-directory) "/findclass.php")))

(define (default-composer-classloader)
  "Return the default composer-classloader package."

  ;; Do not use `@' to avoid introducing circular dependencies.
  (let ((module (resolve-interface '(guixrus packages php))))
    (module-ref module 'composer-classloader)))

(define %composer-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build composer-build-system)
    (guix build json)
    (guix build union)
    ,@%gnu-build-system-modules))

(define* (lower name
                #:key inputs native-inputs outputs system target
                (php (default-php))
                (composer-classloader (default-composer-classloader))
                (findclass (default-findclass))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:target #:php #:composer-classloader #:findclass #:inputs #:native-inputs))

  (and (not target)                               ;XXX: no cross-compilation
       (bag
         (name name)
         (system system)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs

                        ;; Keep the standard inputs of 'gnu-build-system'.
                        ,@(standard-packages)))
         (build-inputs `(("php" ,php)
                         ("findclass.php" ,findclass)
			 ("composer-classloader" ,composer-classloader)
                         ,@native-inputs))
         (outputs outputs)
         (build composer-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (composer-build name inputs
                         #:key
                         source
                         (outputs '("out")) (configure-flags ''())
                         (search-paths '())
                         (out-of-source? #t)
                         (composer-file "composer.json")
                         (tests? #t)
                         (test-target "test")
                         (install-target "install")
                         (validate-runpath? #t)
                         (patch-shebangs? #t)
                         (strip-binaries? #t)
                         (strip-flags ''("--strip-debug"))
                         (strip-directories ''("lib" "lib64" "libexec"
                                               "bin" "sbin"))
                         (phases '(@ (guix build composer-build-system)
                                     %standard-phases))
                         (system (%current-system))
                         (imported-modules %composer-build-system-modules)
                         (modules '((guix build composer-build-system)
                                    (guix build json)
                                    (guix build utils))))
  "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE
provides a 'setup.ml' file as its build system."
  (define builder
    `(begin
       (use-modules ,@modules)
       (composer-build #:source ,(match (assoc-ref inputs "source")
                                   (((? derivation? source))
                                    (derivation->output-path source))
                                   ((source)
                                    source)
                                   (source
                                    source))
                       #:system ,system
                       #:outputs %outputs
                       #:inputs %build-inputs
                       #:search-paths ',(map search-path-specification->sexp
                                             search-paths)
                       #:phases ,phases
                       #:out-of-source? ,out-of-source?
                       #:composer-file ,composer-file
                       #:tests? ,tests?
                       #:test-target ,test-target
                       #:install-target ,install-target
                       #:validate-runpath? ,validate-runpath?
                       #:patch-shebangs? ,patch-shebangs?
                       #:strip-binaries? ,strip-binaries?
                       #:strip-flags ,strip-flags
                       #:strip-directories ,strip-directories)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (gexp->derivation store name builder
                    #:system system
                    #:inputs inputs
                    #:modules imported-modules
                    #:outputs outputs
                    #:guile-for-build guile-for-build))

(define composer-build-system
  (build-system
    (name 'composer)
    (description "The standard Composer build system")
    (lower lower)))

;;; composer.scm ends here
\ No newline at end of file

A guixrus/build-systems/findclass.php => guixrus/build-systems/findclass.php +102 -0
@@ 0,0 1,102 @@
<?php
/**
 * Extract the classes in the given file
 *
 * @param  string            $path The file to check
 * @throws \RuntimeException
 * @return array             The found classes
 */
function findClasses($path)
{
    $extraTypes = PHP_VERSION_ID < 50400 ? '' : '|trait';
    if (defined('HHVM_VERSION') && version_compare(HHVM_VERSION, '3.3', '>=')) {
        $extraTypes .= '|enum';
    }
    // Use @ here instead of Silencer to actively suppress 'unhelpful' output
    // @link https://github.com/composer/composer/pull/4886
    $contents = @php_strip_whitespace($path);
    if (!$contents) {
        if (!file_exists($path)) {
            $message = 'File at "%s" does not exist, check your classmap definitions';
        } elseif (!is_readable($path)) {
            $message = 'File at "%s" is not readable, check its permissions';
        } elseif ('' === trim(file_get_contents($path))) {
            // The input file was really empty and thus contains no classes
            return array();
        } else {
            $message = 'File at "%s" could not be parsed as PHP, it may be binary or corrupted';
        }
        $error = error_get_last();
        if (isset($error['message'])) {
            $message .= PHP_EOL . 'The following message may be helpful:' . PHP_EOL . $error['message'];
        }
        throw new \RuntimeException(sprintf($message, $path));
    }
    // return early if there is no chance of matching anything in this file
    if (!preg_match('{\b(?:class|interface'.$extraTypes.')\s}i', $contents)) {
        return array();
    }
    // strip heredocs/nowdocs
    $contents = preg_replace('{<<<[ \t]*([\'"]?)(\w+)\\1(?:\r\n|\n|\r)(?:.*?)(?:\r\n|\n|\r)(?:\s*)\\2(?=\s+|[;,.)])}s', 'null', $contents);
    // strip strings
    $contents = preg_replace('{"[^"\\\\]*+(\\\\.[^"\\\\]*+)*+"|\'[^\'\\\\]*+(\\\\.[^\'\\\\]*+)*+\'}s', 'null', $contents);
    // strip leading non-php code if needed
    if (substr($contents, 0, 2) !== '<?') {
        $contents = preg_replace('{^.+?<\?}s', '<?', $contents, 1, $replacements);
        if ($replacements === 0) {
            return array();
        }
    }
    // strip non-php blocks in the file
    $contents = preg_replace('{\?>(?:[^<]++|<(?!\?))*+<\?}s', '?><?', $contents);
    // strip trailing non-php code if needed
    $pos = strrpos($contents, '?>');
    if (false !== $pos && false === strpos(substr($contents, $pos), '<?')) {
        $contents = substr($contents, 0, $pos);
    }
    // strip comments if short open tags are in the file
    if (preg_match('{(<\?)(?!(php|hh))}i', $contents)) {
        $contents = preg_replace('{//.* | /\*(?:[^*]++|\*(?!/))*\*/}x', '', $contents);
    }
    preg_match_all('{
        (?:
             \b(?<![\$:>])(?P<type>class|interface'.$extraTypes.') \s++ (?P<name>[a-zA-Z_\x7f-\xff:][a-zA-Z0-9_\x7f-\xff:\-]*+)
           | \b(?<![\$:>])(?P<ns>namespace) (?P<nsname>\s++[a-zA-Z_\x7f-\xff][a-zA-Z0-9_\x7f-\xff]*+(?:\s*+\\\\\s*+[a-zA-Z_\x7f-\xff][a-zA-Z0-9_\x7f-\xff]*+)*+)? \s*+ [\{;]
        )
    }ix', $contents, $matches);
    $classes = array();
    $namespace = '';
    for ($i = 0, $len = count($matches['type']); $i < $len; $i++) {
        if (!empty($matches['ns'][$i])) {
            $namespace = str_replace(array(' ', "\t", "\r", "\n"), '', $matches['nsname'][$i]) . '\\';
        } else {
            $name = $matches['name'][$i];
            // skip anon classes extending/implementing
            if ($name === 'extends' || $name === 'implements') {
                continue;
            }
            if ($name[0] === ':') {
                // This is an XHP class, https://github.com/facebook/xhp
                $name = 'xhp'.substr(str_replace(array('-', ':'), array('_', '__'), $name), 1);
            } elseif ($matches['type'][$i] === 'enum') {
                // In Hack, something like:
                //   enum Foo: int { HERP = '123'; }
                // The regex above captures the colon, which isn't part of
                // the class name.
                $name = rtrim($name, ':');
            }
            $classes[] = ltrim($namespace . $name, '\\');
        }
    }
    return $classes;
}

$options = getopt('i:f:', []);
$file = $options["f"];
$input = $options["i"];

$classes = findClasses($file);
foreach($classes as $class) {
  echo '$classmap[\''.$class.'\'] = \''.$input.'/'.$file.'\';';
  echo "\n";
}
\ No newline at end of file

M guixrus/packages/php.scm => guixrus/packages/php.scm +1 -2
@@ 79,8 79,7 @@ composer-build-system to build its own store-aware autoloading feature.")
                "17c72j29p77gdgh06b9qc0nivmav0k5yc22z4ryygj7dhr1h65nq"))))
    (build-system composer-build-system)
    (arguments
     ;; We do not have phpunit yet
     `(#:tests? #f))
     `(#:tests? #f)) ; We do not have phpunit yet
    (synopsis "Utility for instantiating PHP objects")
    (description "This package provides a small, lightweight utility to
instantiate objects in PHP without invoking their constructors")