/extra/tar/tar.factor

http://github.com/abeaumont/factor · Factor · 232 lines · 139 code · 46 blank · 47 comment · 12 complexity · d45f36f04f6e929a17bded639f7a0df3 MD5 · raw file

  1. ! Copyright (C) 2009 Doug Coleman.
  2. ! See http://factorcode.org/license.txt for BSD license.
  3. USING: accessors byte-arrays combinators io io.backend
  4. io.directories io.encodings.binary io.files io.files.links
  5. io.pathnames io.streams.byte-array io.streams.string kernel
  6. math math.parser namespaces sequences strings summary ;
  7. IN: tar
  8. CONSTANT: zero-checksum 256
  9. CONSTANT: block-size 512
  10. SYMBOL: to-link
  11. : save-link ( link -- )
  12. to-link get push ;
  13. TUPLE: tar-header name mode uid gid size mtime checksum typeflag
  14. linkname magic version uname gname devmajor devminor prefix ;
  15. ERROR: checksum-error header ;
  16. : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
  17. : read-c-string ( n -- str/f )
  18. read [ zero? ] trim-tail [ f ] when-empty >string ;
  19. : read-tar-header ( -- obj )
  20. \ tar-header new
  21. 100 read-c-string >>name
  22. 8 read-c-string trim-string oct> >>mode
  23. 8 read-c-string trim-string oct> >>uid
  24. 8 read-c-string trim-string oct> >>gid
  25. 12 read-c-string trim-string oct> >>size
  26. 12 read-c-string trim-string oct> >>mtime
  27. 8 read-c-string trim-string oct> >>checksum
  28. read1 >>typeflag
  29. 100 read-c-string >>linkname
  30. 6 read >>magic
  31. 2 read >>version
  32. 32 read-c-string >>uname
  33. 32 read-c-string >>gname
  34. 8 read trim-string oct> >>devmajor
  35. 8 read trim-string oct> >>devminor
  36. 155 read-c-string >>prefix ;
  37. : checksum-header ( seq -- n )
  38. 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
  39. : read-data-blocks ( tar-header -- )
  40. dup size>> 0 > [
  41. block-size read [
  42. over size>> dup block-size <= [
  43. head-slice >byte-array write drop
  44. ] [
  45. drop write
  46. [ block-size - ] change-size
  47. read-data-blocks
  48. ] if
  49. ] [
  50. drop
  51. ] if*
  52. ] [
  53. drop
  54. ] if ;
  55. : parse-tar-header ( seq -- obj )
  56. dup checksum-header dup zero-checksum = [
  57. 2drop
  58. \ tar-header new
  59. 0 >>size
  60. 0 >>checksum
  61. ] [
  62. [
  63. binary [ read-tar-header ] with-byte-reader
  64. dup checksum>>
  65. ] dip = [ checksum-error ] unless
  66. ] if ;
  67. ERROR: unknown-typeflag ch ;
  68. M: unknown-typeflag summary ( obj -- str )
  69. ch>> [ "Unknown typeflag: " ] dip prefix ;
  70. : read/write-blocks ( tar-header path -- )
  71. binary [ read-data-blocks ] with-file-writer ;
  72. : prepend-current-directory ( path -- path' )
  73. current-directory get prepend-path ;
  74. ! Normal file
  75. : typeflag-0 ( header -- )
  76. dup name>> prepend-current-directory read/write-blocks ;
  77. TUPLE: hard-link linkname name ;
  78. C: <hard-link> hard-link
  79. TUPLE: symbolic-link linkname name ;
  80. C: <symbolic-link> symbolic-link
  81. ! Hard link, don't call normalize-path
  82. : typeflag-1 ( header -- )
  83. [ linkname>> ] [ name>> ] bi <hard-link> save-link ;
  84. ! Symlink, don't call normalize-path
  85. : typeflag-2 ( header -- )
  86. [ linkname>> ] [ name>> ] bi <symbolic-link> save-link ;
  87. ! character special
  88. : typeflag-3 ( header -- ) unknown-typeflag ;
  89. ! Block special
  90. : typeflag-4 ( header -- ) unknown-typeflag ;
  91. ! Directory
  92. : typeflag-5 ( header -- )
  93. name>> prepend-current-directory make-directories ;
  94. ! FIFO
  95. : typeflag-6 ( header -- ) unknown-typeflag ;
  96. ! Contiguous file
  97. : typeflag-7 ( header -- ) unknown-typeflag ;
  98. ! Global extended header
  99. : typeflag-8 ( header -- ) unknown-typeflag ;
  100. ! Extended header
  101. : typeflag-9 ( header -- ) unknown-typeflag ;
  102. ! Global POSIX header
  103. : typeflag-g ( header -- )
  104. ! Read something like: 52 comment=9f2a940965286754f3a34d5737c3097c05db8725
  105. ! and drop it
  106. [ read-data-blocks ] with-string-writer drop ;
  107. ! Extended POSIX header
  108. : typeflag-x ( header -- ) unknown-typeflag ;
  109. ! Solaris access control list
  110. : typeflag-A ( header -- ) unknown-typeflag ;
  111. ! GNU dumpdir
  112. : typeflag-D ( header -- ) unknown-typeflag ;
  113. ! Solaris extended attribute file
  114. : typeflag-E ( header -- ) unknown-typeflag ;
  115. ! Inode metadata
  116. : typeflag-I ( header -- ) unknown-typeflag ;
  117. ! Long link name
  118. : typeflag-K ( header -- ) unknown-typeflag ;
  119. ! Long file name
  120. : typeflag-L ( header -- )
  121. drop
  122. ;
  123. ! <string-writer> [ read-data-blocks ] keep
  124. ! >string [ zero? ] trim-tail filename set
  125. ! filename get prepend-current-directory make-directories ;
  126. ! Multi volume continuation entry
  127. : typeflag-M ( header -- ) unknown-typeflag ;
  128. ! GNU long file name
  129. : typeflag-N ( header -- ) unknown-typeflag ;
  130. ! Sparse file
  131. : typeflag-S ( header -- ) unknown-typeflag ;
  132. ! Volume header
  133. : typeflag-V ( header -- ) unknown-typeflag ;
  134. ! Vendor extended header type
  135. : typeflag-X ( header -- ) unknown-typeflag ;
  136. : parse-tar ( -- )
  137. block-size read dup length block-size = [
  138. parse-tar-header
  139. dup typeflag>>
  140. {
  141. { 0 [ typeflag-0 ] }
  142. { CHAR: 0 [ typeflag-0 ] }
  143. ! { CHAR: 1 [ typeflag-1 ] }
  144. { CHAR: 2 [ typeflag-2 ] }
  145. ! { CHAR: 3 [ typeflag-3 ] }
  146. ! { CHAR: 4 [ typeflag-4 ] }
  147. { CHAR: 5 [ typeflag-5 ] }
  148. ! { CHAR: 6 [ typeflag-6 ] }
  149. ! { CHAR: 7 [ typeflag-7 ] }
  150. { CHAR: g [ typeflag-g ] }
  151. ! { CHAR: x [ typeflag-x ] }
  152. ! { CHAR: A [ typeflag-A ] }
  153. ! { CHAR: D [ typeflag-D ] }
  154. ! { CHAR: E [ typeflag-E ] }
  155. ! { CHAR: I [ typeflag-I ] }
  156. ! { CHAR: K [ typeflag-K ] }
  157. { CHAR: L [ typeflag-L ] }
  158. ! { CHAR: M [ typeflag-M ] }
  159. ! { CHAR: N [ typeflag-N ] }
  160. ! { CHAR: S [ typeflag-S ] }
  161. ! { CHAR: V [ typeflag-V ] }
  162. ! { CHAR: X [ typeflag-X ] }
  163. { f [ drop ] }
  164. } case parse-tar
  165. ] [
  166. drop
  167. ] if ;
  168. GENERIC: do-link ( object -- )
  169. M: hard-link do-link
  170. [ linkname>> ]
  171. [ name>> prepend-current-directory ] bi make-hard-link ;
  172. M: symbolic-link do-link
  173. [ linkname>> ]
  174. [ name>> prepend-current-directory ] bi make-link ;
  175. ! FIXME: linux tar calls unlinkat and makelinkat
  176. : make-links ( -- )
  177. to-link get [
  178. [ name>> ?delete-file ] [ do-link ] bi
  179. ] each ;
  180. : untar ( path -- )
  181. normalize-path dup parent-directory [
  182. V{ } clone to-link [
  183. binary [ parse-tar ] with-file-reader
  184. make-links
  185. ] with-variable
  186. ] with-directory ;