diff options
Diffstat (limited to 'libguile/ports.c')
-rw-r--r-- | libguile/ports.c | 69 |
1 files changed, 43 insertions, 26 deletions
diff --git a/libguile/ports.c b/libguile/ports.c index 1e1595ff0..4e27a0c55 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -978,40 +978,57 @@ scm_lseek (SCM object, SCM offset, SCM whence) return scm_long2num (rv); } -SCM_PROC (s_ftruncate, "ftruncate", 1, 1, 0, scm_ftruncate); +SCM_PROC (s_truncate_file, "truncate-file", 1, 1, 0, scm_truncate_file); SCM -scm_ftruncate (SCM port, SCM length) +scm_truncate_file (SCM object, SCM length) { - scm_port *pt; - scm_ptobfuns *ptob; + int rv; + off_t c_length; + + /* object can be a port, fdes or filename. */ - port = SCM_COERCE_OUTPORT (port); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, - s_ftruncate); - pt = SCM_PTAB_ENTRY (port); - ptob = scm_ptobs + SCM_PTOBNUM (port); - if (!ptob->ftruncate) - scm_misc_error (s_ftruncate, "port is not truncatable", - scm_cons (port, SCM_EOL)); if (SCM_UNBNDP (length)) { - length = scm_lseek (port, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); + /* must supply length if object is a filename. */ + if (SCM_NIMP (object) && SCM_ROSTRINGP (object)) + scm_wrong_num_args (scm_makfrom0str (s_truncate_file)); + + length = scm_lseek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); } - if (pt->rw_active == SCM_PORT_READ) - scm_read_flush (port); - else if (pt->rw_active == SCM_PORT_WRITE) - ptob->fflush (port); - - { - off_t c_length = scm_num2long (length, (char *)SCM_ARG2, s_ftruncate); + c_length = scm_num2long (length, (char *)SCM_ARG2, s_truncate_file); + if (c_length < 0) + scm_misc_error (s_truncate_file, "negative offset", SCM_EOL); - if (c_length < 0) - scm_misc_error (s_ftruncate, "negative offset", - scm_cons (length, SCM_EOL)); - - ptob->ftruncate (port, c_length); - } + object = SCM_COERCE_OUTPORT (object); + if (SCM_INUMP (object)) + { + SCM_SYSCALL (rv = ftruncate (SCM_INUM (object), c_length)); + } + else if (SCM_NIMP (object) && SCM_OPOUTPORTP (object)) + { + scm_port *pt = SCM_PTAB_ENTRY (object); + scm_ptobfuns *ptob = scm_ptobs + SCM_PTOBNUM (object); + + if (!ptob->ftruncate) + scm_misc_error (s_truncate_file, "port is not truncatable", SCM_EOL); + if (pt->rw_active == SCM_PORT_READ) + scm_read_flush (object); + else if (pt->rw_active == SCM_PORT_WRITE) + ptob->fflush (object); + + ptob->ftruncate (object, c_length); + rv = 0; + } + else + { + SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), + object, SCM_ARG1, s_truncate_file); + SCM_COERCE_SUBSTR (object); + SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), c_length)); + } + if (rv == -1) + scm_syserror (s_truncate_file); return SCM_UNSPECIFIED; } |