ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

image: Add 'target' support.

Browse source 
* gnu/image.scm (<image>)[target]: New field,
(image-target): new public method.
* gnu/system/image.scm (hurd-disk-image): Set "i586-pc-gnu" as image 'target'
field,
(maybe-with-target): new procedure,
(system-image): honor image 'target' field using the above procedure.
This commit is contained in:
Mathieu Othacehe 2020-06-13 14:01:18 +02:00
parent 7ca533c723
commit f292d4719d
No known key found for this signature in database
GPG key ID: 8354763531769CA6
2 changed files with 43 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
gnu/image.scm
View file

@ -33,6 +33,7 @@ (define-module (gnu image)
image image
image-name image-name
image-format image-format
image-target
image-size image-size
image-operating-system image-operating-system
image-partitions image-partitions
@ -67,6 +68,8 @@ (define-record-type* <image>
image make-image image make-image
image? image?
(format image-format) ;symbol (format image-format) ;symbol
(target image-target
(default #f))
(size image-size ;size in bytes as integer (size image-size ;size in bytes as integer
(default 'guess)) (default 'guess))
(operating-system image-operating-system ;<operating-system> (operating-system image-operating-system ;<operating-system>

66
gnu/system/image.scm
View file

@ -104,6 +104,7 @@ (define hurd-initialize-root-partition
(define hurd-disk-image (define hurd-disk-image
(image (image
(format 'disk-image) (format 'disk-image)
(target "i586-pc-gnu")
(partitions (partitions
(list (partition (list (partition
(size 'guess) (size 'guess)
@ -519,6 +520,14 @@ (define (root-uuid os)
(type root-file-system-type)) (type root-file-system-type))
file-systems-to-keep))))) file-systems-to-keep)))))
(define-syntax-rule (maybe-with-target image exp ...)
(let ((target (image-target image)))
(if target
(with-parameters ((%current-target-system target))
exp ...)
(begin
exp ...))))
(define* (system-image image) (define* (system-image image)
"Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660 "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660
image, depending on IMAGE format." image, depending on IMAGE format."
@ -530,32 +539,33 @@ (define substitutable? (image-substitutable? image))
(bootcfg (operating-system-bootcfg os)) (bootcfg (operating-system-bootcfg os))
(bootloader (bootloader-configuration-bootloader (bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os)))) (operating-system-bootloader os))))
(case (image-format image) (maybe-with-target image
((disk-image) (case (image-format image)
(system-disk-image image* ((disk-image)
#:bootcfg bootcfg (system-disk-image image*
#:bootloader bootloader #:bootcfg bootcfg
#:register-closures? register-closures? #:bootloader bootloader
#:inputs `(("system" ,os) #:register-closures? register-closures?
("bootcfg" ,bootcfg)))) #:inputs `(("system" ,os)
((iso9660) ("bootcfg" ,bootcfg))))
(system-iso9660-image ((iso9660)
image* (system-iso9660-image
#:bootcfg bootcfg image*
#:bootloader bootloader #:bootcfg bootcfg
#:register-closures? register-closures? #:bootloader bootloader
#:inputs `(("system" ,os) #:register-closures? register-closures?
("bootcfg" ,bootcfg)) #:inputs `(("system" ,os)
;; Make sure to use a mode that does no imply ("bootcfg" ,bootcfg))
;; HFS+ tree creation that may fail with: ;; Make sure to use a mode that does no imply
;; ;; HFS+ tree creation that may fail with:
;; "libisofs: FAILURE : Too much files to mangle, ;;
;; cannot guarantee unique file names" ;; "libisofs: FAILURE : Too much files to mangle,
;; ;; cannot guarantee unique file names"
;; This happens if some limits are exceeded, see: ;;
;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html ;; This happens if some limits are exceeded, see:
#:grub-mkrescue-environment ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
'(("MKRESCUE_SED_MODE" . "mbr_only"))))))) #:grub-mkrescue-environment
'(("MKRESCUE_SED_MODE" . "mbr_only"))))))))
(define (find-image file-system-type target) (define (find-image file-system-type target)
"Find and return an image built that could match the given FILE-SYSTEM-TYPE, "Find and return an image built that could match the given FILE-SYSTEM-TYPE,
@ -570,4 +580,8 @@ (define (find-image file-system-type target)
(else (else
efi-disk-image))))) efi-disk-image)))))
;;; Local Variables:
;;; eval: (put 'maybe-with-target 'scheme-indent-function 1)
;;; End:
;;; image.scm ends here ;;; image.scm ends here