#ifndef __READTAR_H__
#define __READTAR_H__

#include "mytar.h"

void read_header( union _tar_header *header, FILE *fp );
void extract_data( union _tar_header *header, FILE *fp, char *longname );
void make_directory( union _tar_header *header, char *longname );
char *get_longname( union _tar_header *header, FILE *fp );


#endif /* __READTAR_H__ */

#include "readtar.h"

void read_header( union _tar_header *header, FILE *fp )
{
     fread( ( void * )header, BLOCKSIZE, 1, fp );
}

void extract_data( union _tar_header *header, FILE *fp, char *longname )
{
     char   *name        = header->v7_header.name;
     size_t realsize     = OCT2DEC( header->v7_header.size );
     size_t  block_count = TAR_BLOCK_COUNT( realsize );
     size_t  i           = 0;
     FILE   *fout        = NULL;
     int     remain      = 0;
     char buf[BLOCKSIZE] = { '\0' };

     if( realsize == 0 ) {
          return;
     }

     if( longname != NULL ) {
          name = longname;
     }

     remain = 512 - ( block_count * BLOCKSIZE - realsize );

     fout = fopen( name, "wb" );
     if( !fout ) {
          fprintf( stderr, "Can't open %s.\n", name );
          return;
     }

     for( i = 0; i < block_count - 1; i++ ) {
          fread( ( void * )buf, 1, BLOCKSIZE, fp );
          fwrite( ( void * )buf, 1, BLOCKSIZE, fout );
     }

     fread( ( void * )buf, 1, BLOCKSIZE, fp );
     fwrite( ( void * )buf, 1, remain, fout );

     fclose( fout );
}

void make_directory( union _tar_header *header, char *longname )
{
     char *name = header->v7_header.name;
     mode_t mode = S_IRUSR | S_IWUSR | S_IXUSR |  
          S_IRGRP | S_IWGRP | S_IXGRP |   
          S_IROTH | S_IXOTH | S_IXOTH;

     if( longname != NULL ) {
          name = longname;
     }

     mkdir( name, mode );
}

char *get_longname( union _tar_header *header, FILE *fp )
{
     size_t realsize = OCT2DEC( header->v7_header.size );
     size_t  block_count = TAR_BLOCK_COUNT( realsize );
     char *buf = NULL;
     char *longname = NULL;

     buf = ( char * )malloc( sizeof( char ) * ( block_count * BLOCKSIZE ) );
     memset( buf, 0, ( block_count * BLOCKSIZE ) );
     longname = ( char * )malloc( sizeof( char ) * realsize );
     memset( longname, 0, realsize );

     fread( ( void * )buf, 1, ( block_count * BLOCKSIZE ), fp );
     strncpy( longname, buf, realsize );

     free( buf );
     return longname;
}

int main( int argc, char **argv )
{
     union _tar_header  header;
     FILE              *fp       = NULL;
     char               typeflag = '\0';
     char              *longname = NULL;
     enum _tar_type     type;

     fp = fopen( argv[1], "rb" );
     if( !fp ) {
          fprintf( stderr, "Can't open %s.\n", argv[1] );
          exit( 1 );
     }

     for( ;; ) {
          clear_header( &header );
          read_header( &header, fp );
          if( end_of_tar( &header, fp ) == 1 ) {
               printf( "End of tar.\n" );
               break;
          }
          dump_header( &header );
          printf( "chksum = [%d]\n", calc_chksum( &header ) );
          type = get_type( &header );
          tar_type2str( type );
          /* skip_data( &header, fp ); */

          typeflag = header.v7_header.typeflag;
          switch( ( int )typeflag ) {
          case '0':
          case '\0':
               printf( "type = regular file.\n" );
               extract_data( &header, fp, longname );
               if( longname ) {
                    free( longname );
                    longname = NULL;
               }
               
               /* skip_data( &header, fp ); */
               break;
          
          case '5':
          case 'D':
               printf( "type = directory.\n" );
               make_directory( &header, longname );
               skip_data( &header, fp );
               if( longname ) {
                    free( longname );
                    longname = NULL;
               }
               
               break;
          
          case 'L':
               printf( "type = long name.\n" );
               longname = get_longname( &header, fp );
               printf( "longname = [%s].\n", longname );
               break;
          
          default:
               printf( "Not support yet or unknown type.\n" );
               skip_data( &header, fp );
               break;
          }

          printf( "\n" );
     }

     fclose( fp );
     
     return 0;
}


/* 
 * Local variables:
 * compile-command: "gcc -std=c99 -g3 -o readtar mytar.c readtar.c"
 * End:
 */

#ifndef __WRITETAR_H__
#define __WRITETAR_H__

#include "mytar.h"

void set_file_info( union _tar_header *header, char *src );
void set_directory_info( union _tar_header *header, char *src );
void write_tar_eob( FILE *fp );
void write_tar_header( union _tar_header *header, FILE *fp );
void write_tar_file_content( union _tar_header *header, char *src, FILE *fp );
void write_tar_directory_content( union _tar_header *header, char *src, FILE *fp );
void write_tar_longname_block( char *src, FILE *fp );
int exclude_parent( struct dirent *dir );
int sort_alpha( const struct dirent **a, const struct dirent **b );

#endif /* __WRITETAR_H__ */

#include "writetar.h"

void set_file_info( union _tar_header *header, char *src )
{
     struct stat    s;
     struct passwd *passwd = NULL;
     struct group  *grp    = NULL;

     stat( src, &s );

     strncpy( header->posix_header.name, src, 100 );
     SET_OCT_VALUE( header->posix_header.mode, s.st_mode );
     SET_OCT_VALUE( header->posix_header.uid, s.st_uid );
     SET_OCT_VALUE( header->posix_header.gid, s.st_gid );
     SET_OCT_VALUE( header->posix_header.size, s.st_size );
     SET_OCT_VALUE( header->posix_header.mtime, s.st_mtime );
     header->posix_header.typeflag = '0';

     passwd = getpwuid( s.st_uid );
     strncpy( header->posix_header.uname, passwd->pw_name, 32 );

     grp = getgrgid( s.st_gid );
     strncpy( header->posix_header.gname, grp->gr_name, 32 );

     SET_OCT_VALUE( header->posix_header.chksum, calc_chksum( header ) );
}

void set_directory_info( union _tar_header *header, char *src )
{
     struct stat    s;
     struct passwd *passwd = NULL;
     struct group  *grp    = NULL;

     stat( src, &s );

     strncpy( header->posix_header.name, src, 100 );
     SET_OCT_VALUE( header->posix_header.mode, s.st_mode );
     SET_OCT_VALUE( header->posix_header.uid, s.st_uid );
     SET_OCT_VALUE( header->posix_header.gid, s.st_gid );
     SET_OCT_VALUE( header->posix_header.size, 0 );
     SET_OCT_VALUE( header->posix_header.mtime, s.st_mtime );
     header->posix_header.typeflag = '5';

     passwd = getpwuid( s.st_uid );
     strncpy( header->posix_header.uname, passwd->pw_name, 32 );

     grp = getgrgid( s.st_gid );
     strncpy( header->posix_header.gname, grp->gr_name, 32 );

     SET_OCT_VALUE( header->posix_header.chksum, calc_chksum( header ) );
}

void write_tar_eob( FILE *fp )
{
     fwrite( ( void * )tar_eob, 1, BLOCKSIZE, fp );
     fwrite( ( void * )tar_eob, 1, BLOCKSIZE, fp );
}

void write_tar_header( union _tar_header *header, FILE *fp )
{
     fwrite( ( void * )header, 1, BLOCKSIZE, fp );
}

void write_tar_file_content( union _tar_header *header, char *src, FILE *fp )
{
     size_t  block_count = 0;
     size_t  i           = 0;
     FILE   *fin         = NULL;
     char buf[BLOCKSIZE] = { '\0' };

     clear_header( header );
     set_tar_type( header, TAR_GNU );
     set_file_info( header, src );
     block_count = TAR_BLOCK_COUNT( OCT2DEC( header->posix_header.size ) );

     if( strlen( src ) > 100 ) {
          write_tar_longname_block( src, fp );
     }

     write_tar_header( header, fp );

     fin = fopen( src, "rb" );
     if( !fin ) {
          fprintf( stderr, "Can't open [%s].\n", src );
          return;
     }

     for( i = 0; i < block_count; i++ ) {
          fread( ( void * )buf, 1, BLOCKSIZE, fin );
          fwrite( ( void * )buf, 1, BLOCKSIZE, fp );
          memset( buf, 1, BLOCKSIZE );
     }
}

void write_tar_directory_content( union _tar_header *header, char *src, FILE *fp )
{
     size_t  block_count = 0;
     size_t  i           = 0;
     FILE   *fin         = NULL;

     clear_header( header );
     set_tar_type( header, TAR_GNU );
     set_directory_info( header, src );
     block_count = TAR_BLOCK_COUNT( OCT2DEC( header->posix_header.size ) );

     if( strlen( src ) > 100 ) {
          write_tar_longname_block( src, fp );
     }

     write_tar_header( header, fp );
}

void write_tar_longname_block( char *src, FILE *fp )
{
     union _tar_header  longname_block;
     char              *buf         = NULL;
     size_t             block_count = TAR_BLOCK_COUNT( strlen( src ) );
     size_t             block_size  = block_count * BLOCKSIZE;
     mode_t mode                    = S_IRUSR | S_IWUSR | S_IXUSR |  
          S_IRGRP | S_IWGRP | S_IXGRP |   
          S_IROTH | S_IXOTH | S_IXOTH;

     buf = ( char * )malloc( sizeof( char ) * block_size );
     memset( buf, 0, block_size );
     memcpy( ( void * )buf, ( void * )src, strlen( src ) );

     clear_header( &longname_block );
     set_tar_type( &longname_block, TAR_GNU );
     strncpy( longname_block.posix_header.name, "././@LongLink",
              strlen( "././@LongLink" ) );
     strncpy( longname_block.posix_header.mode, "755", strlen( "755" ) );
     SET_OCT_VALUE( longname_block.posix_header.uid, 0 );
     SET_OCT_VALUE( longname_block.posix_header.gid, 0 );
     SET_OCT_VALUE( longname_block.posix_header.size, strlen( src ) );
     SET_OCT_VALUE( longname_block.posix_header.mtime, 0 );
     longname_block.posix_header.typeflag = 'L';
     strncpy( longname_block.posix_header.uname, "root", strlen( "root" ) );
     strncpy( longname_block.posix_header.gname, "root", strlen( "root" ) );
     SET_OCT_VALUE(longname_block.posix_header.chksum,
                   calc_chksum( &longname_block ) );

     /* 
      * dump_header( &longname_block );
      * printf( "[%s]\n", buf );
      */
     fwrite( ( void * )&longname_block, 1, BLOCKSIZE, fp );
     fwrite( ( void * )buf, 1, block_size, fp );

     free( buf );
}

int exclude_parent( struct dirent *dir )
{
     if( dir->d_name[0] == '.' ) {
          return 0;
     }

     return 1;
}

int sort_alpha( const struct dirent **a, const struct dirent **b )
{
     return strcmp( ( *a )->d_name, ( *b )->d_name );
}

void walk( char *path, FILE *fp )
{
     union _tar_header   header;
     struct dirent     **files = NULL;
     char buf[BUFSIZ]          = { '\0' };
     int                 i     = 0;
     int                 r     = 0;

     r = scandir( path, &files, exclude_parent, sort_alpha );

     if( r == -1 ) {
          fprintf( stderr, "Can't retrieve [%s].\n", path );
          exit( 1 );
     }

     if( path[strlen( path ) - 1] == '/' ) {
          path[strlen( path ) - 1] = '\0';
     }

     write_tar_directory_content( &header, path, fp );
     for( i = 0; i < r; i++ ) {
          if( files[i]->d_type == DT_DIR ) {
               memset( buf, 0, BUFSIZ );
               sprintf( buf, "%s/%s", path, files[i]->d_name );
               walk( buf, fp );
          } else {
               memset( buf, 0, BUFSIZ );
               sprintf( buf, "%s/%s", path, files[i]->d_name );
               write_tar_file_content( &header, buf, fp );
          }
     }
}

int main( int argc, char **argv )
{
     FILE *fp = NULL;

     if( argc < 3 ) {
          fprintf( stderr, "%s tarname dir\n", argv[0] );
          exit( 1 );
     }
     
     fp = fopen( argv[1], "wb" );
     if( !fp ) {
          fprintf( stderr, "Can't open [%s] for C code.\n", argv[1] );
          exit( 1 );
     }

     walk( argv[2], fp );

     write_tar_eob( fp );

     fclose( fp );

     return 0;
}


/* 
 * Local variables:
 * compile-command: "gcc -std=c99 -g3 -o writetar mytar.c writetar.c"
 * End:
 */

#!/usr/local/gauche/bin/gosh
;; -*- coding: utf-8-unix -*-

(define-module tar
  (use file.util)
  (use gauche.uvector)
  (use gauche.collection)

  (export
   *longname*
   <tar-header-base> <tar-header-v7> <tar-header-posix> <tar-header-gnuold>
   <tar> <tar-reader> <tar-writer>
   calc-chksum tar-type set-tar-type
   clear-tar-header end-of-tar? skip-tar-data read-tar-header
   write-tar-eob write-tar-header write-tar-longname-block
   write-tar-file-content write-tar-directory-content
   open-input-tar close-input-tar call-with-iterator
   extract-tar-data call-with-input-tar
   open-output-tar close-output-tar add-file))

(select-module tar)

(define *longname* #f)
(define *tar-block-size* 512)
(define *tar-eob* (make-uvector <s8vector> *tar-block-size* 0))
(define-macro (tar-block-count size)
  `(x->integer (floor (/ (+ ,size 511) 512))))

(define-macro (get-data cls beg end :optional (is-terminate? #t))
  `(cond
    ((eq? ,is-terminate? #t)
     (s8vector->string (uvector-copy (~ ,cls 'header) ,beg ,end)
                       0 ,(- end beg) 0))
    (else
     (s8vector->string (uvector-copy (~ ,cls 'header) ,beg ,end)
                       0 ,(- end beg)))))
(define-macro (set-data cls data beg :optional (converter identity))
  `(s8vector-copy! (~ ,cls 'header) ,beg
                   (string->s8vector (,converter ,data))))

(define-macro (safe-string->number data radix)
  `(let ((v (gensym)))
     (set! v (string->number ,data ,radix))
     (if (eq? v #f) 0 v)))

(define (safe-substring src start end)
  (let ((true-end end))
    (if (> true-end #0=(string-length src))
      (set! true-end #0#))
    (substring src start true-end)))

(define-class <tar-header-base> ()
  ((header   :init-form (make-uvector <s8vector> *tar-block-size* 0))
   (name     :allocation :virtual
             :slot-ref (^o (get-data o 0 100)) 
             :slot-set! (^(o v) (set-data o v 0 (cut safe-substring <> 0 100))))
   (mode     :allocation :virtual 
             :slot-ref (^o (safe-string->number (get-data o 100 108) 10)) 
             :slot-set! (^(o v) (set-data o v 100 (cut format #f "~o" <>))))
   (uid      :allocation :virtual 
             :slot-ref (^o (safe-string->number (get-data o 108 116) 8)) 
             :slot-set! (^(o v) (set-data o v 108 (cut format #f "~o" <>))))
   (gid      :allocation :virtual 
             :slot-ref (^o (safe-string->number (get-data o 116 124) 8)) 
             :slot-set! (^(o v) (set-data o v 116 (cut format #f "~o" <>))))
   (size     :allocation :virtual 
             :slot-ref (^o (safe-string->number (get-data o 124 136) 8)) 
             :slot-set! (^(o v) (set-data o v 124 (cut format #f "~o" <>))))
   (mtime    :allocation :virtual 
             :slot-ref (^o (safe-string->number (get-data o 136 148) 8)) 
             :slot-set! (^(o v) (set-data o v 136 (cut format #f "~o" <>))))
   (chksum   :allocation :virtual 
             :slot-ref (^o (safe-string->number (get-data o 148 156) 8)) 
             :slot-set! (^(o v) (set-data o v 148 (cut format #f "~o" <>))))
   (typeflag :allocation :virtual 
             :slot-ref (^o (get-data o 156 157 #f)) 
             :slot-set! (^(o v) (set-data o v 156)))
   (linkname :allocation :virtual 
             :slot-ref (^o (get-data o 157 257)) 
             :slot-set! (^(o v) (set-data o v 157)))
   ))

(define-class <tar-header-v7> (<tar-header-base>)
  ((pad :allocation :virtual 
        :slot-ref (^o (get-data o 257 512)))))

(define-class <tar-header-posix> (<tar-header-base>)
  ((magic    :allocation :virtual 
             :slot-ref (^o (get-data o 257 263 #f)) 
             :slot-set! (^(o v) (set-data o v 257)))
   (version  :allocation :virtual 
             :slot-ref (^o (get-data o 263 265 #f)) 
             :slot-set! (^(o v) (set-data o v 263)))
   (uname    :allocation :virtual 
             :slot-ref (^o (get-data o 265 297)) 
             :slot-set! (^(o v) (set-data o v 265 (cut safe-substring <> 0 32))))
   (gname    :allocation :virtual 
             :slot-ref (^o (get-data o 297 329)) 
             :slot-set! (^(o v) (set-data o v 297 (cut safe-substring <> 0 32))))
   (devmajor :allocation :virtual 
             :slot-ref (^o (get-data o 329 337)) 
             :slot-set! (^(o v) (set-data o v 329)))
   (devminor :allocation :virtual 
             :slot-ref (^o (get-data o 337 345)) 
             :slot-set! (^(o v) (set-data o v 337)))
   (prefix   :allocation :virtual 
             :slot-ref (^o (get-data o 345 500)) 
             :slot-set! (^(o v) (set-data o v 345)))
   (pad      :allocation :virtual 
             :slot-ref (^o (get-data o 500 512)) 
             :slot-set! (^(o v) (set-data o v 512)))))


(define-class <tar-header-gnuold> (<tar-header-base>)
  ((magic       :allocation :virtual 
                :slot-ref (^o (get-data o 257 263 #f)) 
                :slot-set! (^(o v) (set-data o v 257)))
   (version     :allocation :virtual 
                :slot-ref (^o (get-data o 263 265 #f)) 
                :slot-set! (^(o v) (set-data o v 263 (cut safe-substring <> 0 32))))
   (uname       :allocation :virtual 
                :slot-ref (^o (get-data o 265 297)) 
                :slot-set! (^(o v) (set-data o v 265 (cut safe-substring <> 0 32))))
   (gname       :allocation :virtual 
                :slot-ref (^o (get-data o 297 329)) 
                :slot-set! (^(o v) (set-data o v 297)))
   (devmajor    :allocation :virtual 
                :slot-ref (^o (get-data o 329 337)) 
                :slot-set! (^(o v) (set-data o v 329)))
   (devminor    :allocation :virtual 
                :slot-ref (^o (get-data o 337 345)) 
                :slot-set! (^(o v) (set-data o v 337)))
   (atime       :allocation :virtual 
                :slot-ref (^o (safe-string->number (get-data o 345 357) 8))
                :slot-set! (^(o v) (set-data o v 345 (cut format #f "~o" <>))))
   (ctime       :allocation :virtual 
                :slot-ref (^o (safe-string->number (get-data o 357 369) 8)) 
                :slot-set! (^(o v) (set-data o v 357 (cut format #f "~o" <>))))
   (offset      :allocation :virtual 
                :slot-ref (^o (get-data o 369 381)) 
                :slot-set! (^(o v) (set-data o v 369)))
   (longnames   :allocation :virtual 
                :slot-ref (^o (get-data o 381 385)) 
                :slot-set! (^(o v) (set-data o v 381)))
   (unused-pad2 :allocation :virtual 
                :slot-ref (^o (get-data o 385 386)) 
                :slot-set! (^(o v) (set-data o v 385)))
   (sparse      :allocation :virtual 
                :slot-ref (^o (get-data o 386 482)) 
                :slot-set! (^(o v) (set-data o v 386)))
   (isextended  :allocation :virtual 
                :slot-ref (^o (get-data o 482 483)) 
                :slot-set! (^(o v) (set-data o v 482)))
   (realsize    :allocation :virtual 
                :slot-ref (^o (get-data o 483 495)) 
                :slot-set! (^(o v) (set-data o v 483)))
   (pad         :allocation :virtual 
                :slot-ref (^o (get-data o 495 512)) 
                :slot-set! (^(o v) (set-data o v 495)))))

(define-class <tar> ()
  ((name :init-form "")
   (ioport :init-form #f)
   (direction :allocation :virtual
              :slot-ref (^o
                         (cond
                          ((eq? (input-port? (~ o 'ioport)) #t)
                           'input)
                          ((eq? (output-port? (~ o 'ioport)) #t)
                           'output)
                          (else 'unknown))))
   (is-closed? :allocation :virtual
               :slot-ref (^o (port-closed? (~ o 'ioport))))))

(define-class <tar-reader> (<tar> <collection>)
  ((skip-data? :init-form #f)))

(define-class <tar-writer> (<tar>)
  ((filelist :init-form '())))

(define (calc-chksum header)
  (let ((total 0))
    (dotimes (i 512)
      (cond
       ((and (>= i 148) (< i 156))
        (set! total (+ total 32))) ;;; space
       (else
        (set! total (+ total (uvector-ref (~ header 'header) i))))))
    total))

(define-method tar-type ((header <tar-header-base>))
  (cond
   ((and (= (uvector-ref #0=(~ header 'header) 257) 0)
         (= (uvector-ref #0# 263) 0))
    'tar-v7)
   ((and (string=? (s8vector->string #0# 257 263) "ustar ")
         (string=? (s8vector->string #0# 263 265) " \0"))
    'tar-gnu) 
   ((and (string=? (s8vector->string #0# 257 263) "ustar\0")
         (string=? (s8vector->string #0# 263 265) "00"))
    'tar-posix)
   (else 'tar-unknown)))

(define-method set-tar-type ((header <tar-header-base>) type)
  (cond
   ((eq? type 'tar-v7)
    (set! (uvector-ref (~ header 'header) 257) 0)
    (set! (uvector-ref (~ header 'header) 263) 0))
   ((eq? type 'tar-posix)
    (set! (~ header 'magic) "ustar ")
    (set! (~ header 'version) " \0"))
   ((eq? type 'tar-gnu)
    (set! (~ header 'magic) "ustar\0")
    (set! (~ header 'version) "00"))))

(define-method clear-tar-header ((header <tar-header-base>))
  (uvector-copy! (~ header 'header) 0 *tar-eob*))

(define-method end-of-tar? ((tar <tar>) (header <tar-header-base>))
  (if (not (= (uvector-ref #0=(~ header 'header) 0) 0))
    #f
    (begin
      (if (and (= (uvector-ref #0# 0) 0)
               (= (s8vector-dot #0# *tar-eob*) 0))
        (let ((next-header #f))
          (skip-tar-data tar header)
          (set! next-header (read-tar-header tar))
          (if (and (= (uvector-ref #1=(~ next-header 'header) 0) 0)
                   (= (s8vector-dot #1# *tar-eob*) 0))
            #t))))))

(define-method skip-tar-data ((tar <tar>) (header <tar-header-base>))
  (let ((block-count (tar-block-count (~ header 'size))))
    (port-seek (~ tar 'ioport) (* block-count *tar-block-size*) SEEK_CUR)
    (set! (~ tar 'skip-data?) #f)))

(define-method read-tar-header ((tar <tar>) :optional (read-tar-type #f))
  (let ((header (make <tar-header-posix>))
        (type (or read-tar-type 'tar-unknown)))
    (set! (~ tar 'skip-data?) #t)
    (set! (~ header 'header)
          (read-uvector <s8vector> *tar-block-size* (~ tar 'ioport)))
    (set! type (tar-type header))
    (cond
     ((eq? type 'tar-gnu)
      (let ((new-header (make <tar-header-gnuold>)))
        (uvector-copy! (~ new-header 'header) 0 (~ header 'header))
        new-header))
     ((eq? type 'tar-v7)
      (let ((new-header (make <tar-header-v7>)))
        (uvector-copy! (~ new-header 'header) 0 (~ header 'header))
        new-header))
     (else header))))

(define-method make-tar-directory ((tar <tar>) (header <tar-header-base>) :optional (longname #f))
  (let ((name (or longname (~ header 'name))))
    (make-directory* name)
    (set! (~ tar 'skip-data?) #t)))

(define-method get-tar-long-name ((tar <tar>) (header <tar-header-base>))
  (let ((block-count (tar-block-count (~ header 'size)))
        (vec #f))
    (set! vec (read-uvector <s8vector> #0=(* block-count *tar-block-size*)
                            (~ tar 'ioport)))
    (begin0 
        (s8vector->string vec 0 #0# 0)
      (set! (~ tar 'skip-data?) #f))))

(define-method _extract-tar-data ((tar <tar>) (header <tar-header-base>) :optional (longname #f) (output #f) (closer close-output-port))
  (let* ((name (or longname (~ header 'name)))
         (block-count (tar-block-count #0=(~ header 'size)))
         (remain 0)
         (buf #f)
         (out (or output (open-output-file name))))
    (if (not (= #0# 0))
      (begin
        (set! remain (- 512 (- (* block-count *tar-block-size*) #0#)))
        (unwind-protect
         (begin 
           (dotimes (i (- block-count 1))
             (begin
               (set! buf (read-uvector <s8vector> *tar-block-size* (~ tar 'ioport)))
               (write-uvector buf out 0 *tar-block-size*)
               (uvector-copy! buf 0 *tar-eob*)))
           (begin
             (if (not (eq? buf #f)) (uvector-copy! buf 0 *tar-eob*))
             (set! buf (read-uvector <s8vector> *tar-block-size* (~ tar 'ioport)))
             (write-uvector buf out 0 remain)))
         (closer out))))
    (set! (~ tar 'skip-data?) #f)))

(define-method set-tar-file-info ((tar <tar>) (header <tar-header-base>) src)
  (set! (~ header 'name) src)
  (set! (~ header 'mode) (file-mode src))
  (set! (~ header 'uid) (file-uid src))
  (set! (~ header 'gid) (file-gid src))
  (set! (~ header 'size) (file-size src))
  (set! (~ header 'mtime) (file-mtime src))
  (set! (~ header 'typeflag) "0")
  (set! (~ header 'uname) (sys-uid->user-name (file-uid src)))
  (set! (~ header 'gname) (sys-gid->group-name (file-gid src)))
  (set! (~ header 'chksum) (calc-chksum header)))

(define-method set-tar-directory-info ((tar <tar>) (header <tar-header-base>) src)
  (set! (~ header 'name) src)
  (set! (~ header 'mode) (file-mode src))
  (set! (~ header 'uid) (file-uid src))
  (set! (~ header 'gid) (file-gid src))
  (set! (~ header 'size) 0)
  (set! (~ header 'mtime) (file-mtime src))
  (set! (~ header 'typeflag) "5")
  (set! (~ header 'uname) (sys-uid->user-name (file-uid src)))
  (set! (~ header 'gname) (sys-gid->group-name (file-gid src)))
  (set! (~ header 'chksum) (calc-chksum header)))

(define-method write-tar-eob ((tar <tar>) (header <tar-header-base>))
  (dotimes (i 2)
    (write-uvector *tar-eob* (~ tar 'ioport))))

(define-method write-tar-header ((tar <tar>) (header <tar-header-base>))
  (write-uvector (~ header 'header) (~ tar 'ioport)))

(define-method write-tar-longname-block ((tar <tar>) src)
  (let* ((longname-header (make <tar-header-posix>))
         (block-count (tar-block-count (string-length src)))
         (buf (make-uvector <s8vector> (* block-count *tar-block-size*) 0)))
    (clear-tar-header #0=longname-header)
    (set-tar-type #0# 'tar-gnu)
    (set! (~ #0# 'name) "././@LongLink")
    (set! (~ #0# 'mode) (string->number "755" 8))
    (set! (~ #0# 'uid) 0)
    (set! (~ #0# 'gid) 0)
    (set! (~ #0# 'size) (string-length src))
    (set! (~ #0# 'mtime) 0)
    (set! (~ #0# 'typeflag) "L")
    (set! (~ #0# 'uname) "root")
    (set! (~ #0# 'gname) "root")
    (set! (~ #0# 'chksum) (calc-chksum #0#))

    (write-uvector (~ #0# 'header) (~ tar 'ioport) 0 *tar-block-size*)
    (uvector-copy! buf 0 (string->u8vector src))
    (write-uvector buf (~ tar 'ioport) 0 *tar-block-size*)))

(define-method write-tar-file-content ((tar <tar>) (header <tar-header-base>) src)
  (let ((block-count 0)
        (buf (make-uvector <s8vector> *tar-block-size* 0)))
    (clear-tar-header header)
    (set-tar-type header 'tar-gnu)
    (set-tar-file-info tar header src)
    (set! block-count (tar-block-count (~ header 'size)))
    (if (> (string-length src) 100)
      (write-tar-longname-block tar src))
    (write-tar-header tar header)
    (call-with-input-file src
      (^(in)
        (dotimes (i block-count)
          (uvector-copy! buf 0 (read-uvector <s8vector> *tar-block-size* in))
          (write-uvector buf (~ tar 'ioport) 0 *tar-block-size*)
          (uvector-copy! buf 0 *tar-eob*))))))

(define-method write-tar-directory-content ((tar <tar>) (header <tar-header-base>) src)
  (let ((block-count 0)
        (buf #f))
    (clear-tar-header header)
    (set-tar-type header 'tar-gnu)
    (set-tar-directory-info tar header src)
    (set! block-count (tar-block-count (~ header 'size)))
    (if (> (string-length src) 100)
      (write-tar-longname-block tar src))
    (write-tar-header tar header)))

(define (open-input-tar src)
  (let ((tar (make <tar-reader>)))
    (set! (~ tar 'name) src)
    (set! (~ tar 'ioport) (open-input-file src))
    tar))

(define-method close-input-tar ((tar <tar-reader>))
  (close-input-port (~ tar 'ioport))
  (set! (~ tar 'name) ""))

(define-method call-with-iterator ((tar <tar-reader>) proc . opts)
  (let ((tar-header #f))
    (proc 
     (lambda ()
       (if (and (eq? (~ tar 'skip-data?) #t)
                (not (eq? tar-header #f)))
         (begin
           (skip-tar-data tar tar-header)
           (set! (~ tar 'skip-data?) #t)))
       (set! tar-header (read-tar-header tar))
       (end-of-tar? tar tar-header))
     (lambda () tar-header))))

(define-method extract-tar-data ((tar <tar>) (header <tar-header-base>) :optional (output #f) (closer close-output-port) (create-directory? #t))
  (let ((flag (~ header 'typeflag)))
    (cond
     ((or (string=? "0" flag)
          (string=? "\0" flag))
      (_extract-tar-data tar header *longname* output closer)
      (set! *longname* #f))
     ((or (string=? "5" flag)
          (string=? "D" flag))
      (if (eq? create-directory? #t)
        (make-tar-directory tar header *longname*))
      (set! *longname* #f))
     ((string=? "L" flag)
      (set! *longname* (get-tar-long-name tar header)))
     (else
      (format #t "unknown type or not implement yet.\n")))))

(define (call-with-input-tar src proc)
  (let ((tar-reader (open-input-tar src)))
    (unwind-protect
     (proc tar-reader)
     (close-input-tar tar-reader))))

(define (open-output-tar src)
  (let ((tar (make <tar-writer>)))
    (set! (~ tar 'name) src)
    tar))

(define-method close-output-tar ((tar <tar-writer>))
  (set! (~ tar 'ioport) (open-output-file (~ tar 'name)))
  (unwind-protect
   (let ((tar-header (make <tar-header-posix>)))
     (dolist (file (reverse (~ tar 'filelist)))
       (cond
        ((eq? (file-is-regular? file) #t)
         (write-tar-file-content tar tar-header file))
        ((eq? (file-is-directory? file) #t)
         (write-tar-directory-content tar tar-header file))))
     (write-tar-eob tar tar-header))
   (close-output-port (~ tar 'ioport))))

(define-method add-file ((tar <tar-writer>) src)
  (set! #0=(~ tar 'filelist) (append (list src) #0#)))