The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "fmmacar.h"
#include "tomacar.h"

#define PkgName "Lingua::AR::MacArabic"

/* Perl 5.6.1 ? */
#ifndef uvuni_to_utf8
#define uvuni_to_utf8   uv_to_utf8
#endif /* uvuni_to_utf8 */

/* Perl 5.6.1 ? */
#ifndef utf8n_to_uvuni
#define utf8n_to_uvuni  utf8_to_uv
#endif /* utf8n_to_uvuni */

#define SBCS_LEN	1

#define FromMacTbl	fm_macar_tbl
#define FromMacDir	fm_macar_dir
#define ToMacTbl 	to_macar_table
#define ToMacTblN	to_macar_N
#define ToMacTblL	to_macar_L
#define ToMacTblR	to_macar_R

static STDCHAR ** ToMacTbl [] = {
    ToMacTblN,
    ToMacTblL,
    ToMacTblR
};

static void
sv_cat_cvref (SV *dst, SV *cv, SV *sv)
{
    dSP;
    int count;
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    XPUSHs(sv_2mortal(sv));
    PUTBACK;
    count = call_sv(cv, (G_EVAL|G_SCALAR));
    SPAGAIN;
    if (SvTRUE(ERRSV) || count != 1) {
	croak("died in XS, " PkgName "\n");
    }
    sv_catsv(dst,POPs);
    PUTBACK;
    FREETMPS;
    LEAVE;
}

MODULE = Lingua::AR::MacArabic	PACKAGE = Lingua::AR::MacArabic
PROTOTYPES: DISABLE

void
decode(...)
  ALIAS:
    decodeMacArabic = 1
  PREINIT:
    SV *src, *dst;
    STRLEN srclen;
    U8 *s, *e, *p, uni[UTF8_MAXLEN + 1];
    UV uv;
    STDCHAR curdir, predir;
  PPCODE:
    if (0 < items && SvROK(ST(0))) {
	croak(PkgName " 1st argument is REF, but handler for decode is NG.");
    }
    src = (0 < items) ? ST(0) : &PL_sv_undef;

    if (SvUTF8(src)) {
	src = sv_mortalcopy(src);
	sv_utf8_downgrade(src, 0);
    }
    s = (U8*)SvPV(src,srclen);
    e = s + srclen;
    dst = sv_2mortal(newSV(1));
    (void)SvPOK_only(dst);
    SvUTF8_on(dst);

    predir = MACBIDI_DIR_NT;
    for (p = s; p < e; p++, predir = curdir) {
	curdir = FromMacDir[*p];

	if (predir != curdir) {
	    if (predir != MACBIDI_DIR_NT) {
		uv = MACBIDI_UV_PDF;
		(void)uvuni_to_utf8(uni, uv);
		sv_catpvn(dst, (char*)uni, (STRLEN)UNISKIP(uv));
	    }
	    if (curdir != MACBIDI_DIR_NT) {
		uv = (curdir == MACBIDI_DIR_LR) ? MACBIDI_UV_LRO :
		     (curdir == MACBIDI_DIR_RL) ? MACBIDI_UV_RLO :
		     0; /* Panic: undefined direction in decode" */;
		(void)uvuni_to_utf8(uni, uv);
		sv_catpvn(dst, (char*)uni, (STRLEN)UNISKIP(uv));
	    }
	}

	uv = FromMacTbl[*p];
	(void)uvuni_to_utf8(uni, uv);
	sv_catpvn(dst, (char*)uni, (STRLEN)UNISKIP(uv));
    }

    if (predir != MACBIDI_DIR_NT) {
	uv = MACBIDI_UV_PDF;
	(void)uvuni_to_utf8(uni, uv);
	sv_catpvn(dst, (char*)uni, (STRLEN)UNISKIP(uv));
    }
    XPUSHs(dst);



void
encode(...)
  ALIAS:
    encodeMacArabic = 1
  PREINIT:
    SV *src, *dst, *ref;
    STRLEN srclen, retlen;
    U8 *s, *e, *p;
    STDCHAR b, *t, **table;
    UV uv;
    STDCHAR dir;
    bool has_cv = FALSE;
    bool has_pv = FALSE;
  PPCODE:
    ref = NULL;
    if (0 < items && SvROK(ST(0))) {
	ref = SvRV(ST(0));
	if (SvTYPE(ref) == SVt_PVCV)
	    has_cv = TRUE;
	else if (SvPOK(ref))
	    has_pv = TRUE;
	else
	    croak(PkgName " 1st argument is not STRING nor CODEREF");
    }
    src = ref
	? (1 < items) ? ST(1) : &PL_sv_undef
	: (0 < items) ? ST(0) : &PL_sv_undef;

    if (!SvUTF8(src)) {
	src = sv_mortalcopy(src);
	sv_utf8_upgrade(src);
    }
    s = (U8*)SvPV(src,srclen);
    e = s + srclen;
    dst = sv_2mortal(newSV(1));
    (void)SvPOK_only(dst);
    SvUTF8_off(dst);

    dir = MACBIDI_DIR_NT;

    for (p = s; p < e;) {
	uv = utf8n_to_uvuni(p, e - p, &retlen, 0);
	p += retlen;

	switch (uv) {
	case MACBIDI_UV_PDF:
	    dir = MACBIDI_DIR_NT;
	    break;
	case MACBIDI_UV_LRO:
	    dir = MACBIDI_DIR_LR;
	    break;
	case MACBIDI_UV_RLO:
	    dir = MACBIDI_DIR_RL;
	    break;
	default:
	    table = ToMacTbl[dir];
	    t = uv < 0x10000 ? table[uv >> 8] : NULL;
	    b = t ? t[uv & 0xff] : 0;

	    if (b || uv == 0)
		sv_catpvn(dst, (char*)&b, SBCS_LEN);
	    else if (has_pv)
		sv_catsv(dst, ref);
	    else if (has_cv)
		sv_cat_cvref(dst, ref, newSVuv(uv));
	}
    }
    XPUSHs(dst);