#!/usr/local/bin/perl
;#
;# fold.pl: line folding library for Perl as well as a fold(1) clone.
;#
;# This is a Perl library as well as a directly executable command.
;# You can include this file from other Perl program or execute
;# directly as a command.
;#
;# Copyright (c) 2002 Kazumasa Utashiro <utashiro@srekcah.org>
;# Copyright (c) 1995,1998 Kazumasa Utashiro <utashiro@iij.ad.jp>
;# Internet Initiative Japan Inc.
;# 3-13 Kanda Nishiki-cho, Chiyoda-ku, Tokyo 101-0054, Japan
;#
;# Copyright (c) 1993 Kazumasa Utashiro
;# Software Research Associates, Inc.
;#
;# Original version: 25 Mar 1993
;#
;# Use and redistribution for ANY PURPOSE are granted as long as all
;# copyright notices are retained.  Redistribution with modification
;# is allowed provided that you make your modified version obviously
;# distinguishable from the original one.  THIS SOFTWARE IS PROVIDED
;# BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES ARE
;# DISCLAIMED.
;#
;; $rcsid = q$Id: fold.pl,v 1.6 2002/04/05 18:31:59 utashiro Exp $;
;#
;# For the latest information, consult this page:
;#
;#	http://www.srekcah.org/~utashiro/perl/scripts/
;#
;# It may be written in Japanese only, though.  Sorry.
;#

if (__FILE__ eq $0) {
    ($myname = $0) =~ s:.*/::;
    Usage:					$usage = <<"    ;";
	$myname [-width] [-w] [-p] [-t] [-f] [-s]
	-width: specify folding width (default 80)
	-w:	fold on word boundaries
	-p:	put padding spaces at the end of line
	-t:	truncate by width
	-f:	replace final newline by space and fill text
	-s:	delete leading space
    ;
    $width = 80;
    while ($_ = $ARGV[$[], s/^-(.+)$/$1/ && shift) {
	next unless length;
	if (s/^(\d+)//) { $width = $1;   redo; }
	if (s/^w//)     { $onword = 1;   redo; }
	if (s/^p//)     { $padding = 1;  redo; }
	if (s/^t//)     { $truncate = 1; redo; }
	if (s/^f//)     { $/ = '';       redo; }
	if (s/^s//)     { $delete_leading_space = 1; redo; }
	if (s/^e//)     { ($expand = shift) && redo; }
	print STDERR "Usage:", $usage, "\n$rcsid\n"; exit(!/^h/);
    }
    while (<>) {
	s/\n([\200-\377])/$1/g;		# filling multibyte character
	s/\n([^\n])/ $1/g;		# filling ASCII
	while (length) {
	    ($l, $_) = &fold($_, $width, $padding, $onword, $expand);
	    $l =~ s/^ // if $delete_leading_space;
	    print $l;
	    print "\n" if length;
	    last if $truncate;
	}
    }
    exit(0);
}

######################################################################

package fold;
;#
;# SYNOPSIS
;#
;#	($folded, $rest) = &fold(LINE, WIDTH, PADDING, ONWORD, EXPAND, COLUMN);
;#
;# DESCRIPTION
;#
;#	Pass the line to be folded as a first argument and folding width as
;#	a second argument.  If optional third argument is true, space
;#	character will be padded at the end of the line if necessary.  If
;#	the fourth argument is true, the line is folded on the word
;#	boundaries.  The fifth argument is a string which specifies what
;#	character is expanded by spaces and backspaces ('r' for carriage
;#	return, 't' for tab and 'a' for all).  The sixth argument specifies
;#	start column of the string to caliculate tab stop.
;#
;#	Return value is a list of a folded line and the rest.
;#
;; $rcsid = q$Id: fold.pl,v 1.6 2002/04/05 18:31:59 utashiro Exp $;
;#	
sub main'fold {
    local($_, $width, $padding, $onword, $expand, $start) = @_;
    local($l, $room) = ('', $width);
    local($n, $c, $r, $mb);

    while (length) {
	if (s/^\cH//) {
	    $c = "\cH";
	    if ($room < $width) {
		$room++;
	    } elsif ($start > 0) {
		$start--;
	    }
	    next;
	}
	if (s/^\r//) {
	    if ($expand =~ /[ar]/) {
		$c = "\cH" x ($width - $room + $start);
	    } else {
		$c = "\r";
	    }
	    $room = $width + $start;
	    $start = 0;
	    next;
	}
	last if $room <= 0 || (/^[\200-\377]/ && $room < 2);
	if (s/^\t//) {
	    $space = 8 - ($start + $width - $room) % 8;
	    if ($expand =~ /[at]/) {
		$_ = (' ' x $space) . $_;
		redo;
	    } else {
		$room -= $space;
		$c = "\t";
		$l .= $c, last if $room <= 0;
		next;
	    }
	}
	if (($mb = s/^(([\200-\377].)+)//) || s/([^\t\b\r\200-\377]+)//) {
	    $n = $room;
	    $n -= $room % 2 if $mb;
	    ($c, $r) = unpack("a$n a*", $1);
	    $room -= length($c);
	    $_ = $r . $_;
	} else {
	    die "&fold: panic";
	}
    } continue {
	$l .= $c;
    }
    if ($onword && /^\w/ && !$mb && $l =~ s/([^\w\b])([\w\b]+)$/$1/) {
	$cut = $2;
	if ($l =~ /[\200-\377]$/) { # This check is not necessary for EUC
	    local(@tmp) = $l =~ /[\200-\377]?./g;
	    (pop(@tmp) =~ /^[\200-\377]$/) && ($cut =~ s/^(.)//) && ($l .= $1);
	}
	$_ = $cut . $_;
	$room += &pwidth($cut) if $padding;
    }
    $l .= ' ' x $room if $padding;
    ($l, $_);
}

sub pwidth {
    local($_) = @_;
    return(length) unless /[\cH\f\r]/;
    s/^.*[\f\r]//;
    1 while s/[^\cH]\cH//;
    s/^\cH+//;
    length;
}

1;