/*  You may distribute under the terms of either the GNU General Public License
 *  or the Artistic License (the same terms as Perl itself)
 *
 *  (C) Paul Evans, 2010 -- leonerd@leonerd.org.uk
 *
 * Much of this code inspired by http://search.cpan.org/~jjore/UNIVERSAL-ref-0.12/
 */

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define NEED_sv_2pv_flags
#include "../../ppport.h"

static int init_done = 0;

OP *(*real_pp_substr)(pTHX);

typedef struct {
  GV *substr_method;
  SV *offset;
  SV *length;
} overload_substr_ctx;

static int magic_get(pTHX_ SV *sv, MAGIC *mg)
{
  dSP;
  overload_substr_ctx *ctx = (void *)mg->mg_ptr;
  SV *result;
  int count;

  ENTER;
  SAVETMPS;

  PUSHMARK(SP);
  XPUSHs(mg->mg_obj);
  XPUSHs(ctx->offset);
  if(ctx->length)
    XPUSHs(ctx->length);
  else
    XPUSHs(&PL_sv_undef);
  PUTBACK;

  count = call_sv((SV*)GvCV(ctx->substr_method), G_SCALAR);
  assert(count == 1);

  SPAGAIN;
  result = POPs;

  sv_setsv_nomg(sv, result);

  PUTBACK;
  FREETMPS;
  LEAVE;

  return 1;
}

static int magic_set(pTHX_ SV *sv, MAGIC *mg)
{
  dSP;
  overload_substr_ctx *ctx = (void *)mg->mg_ptr;

  ENTER;
  SAVETMPS;

  PUSHMARK(SP);
  XPUSHs(mg->mg_obj);
  XPUSHs(ctx->offset);
  if(ctx->length)
    XPUSHs(ctx->length);
  else
    XPUSHs(&PL_sv_undef);
  XPUSHs(sv);
  PUTBACK;

  call_sv((SV*)GvCV(ctx->substr_method), G_SCALAR|G_DISCARD);

  FREETMPS;
  LEAVE;

  return 1;
}

static int magic_free(pTHX_ SV *sv, MAGIC *mg)
{
  overload_substr_ctx *ctx = (void *)mg->mg_ptr;

  SvREFCNT_dec(ctx->substr_method);
  SvREFCNT_dec(ctx->offset);
  if(ctx->length)
    SvREFCNT_dec(ctx->length);

  Safefree(ctx);

  return 1;
}

static MGVTBL vtbl = {
  &magic_get,
  &magic_set,
  NULL, /* len   */
  NULL, /* clear */
  &magic_free,
};

PP(pp_overload_substr) {
  dSP; dTARG;
  const int num_args = PL_op->op_private & 7; /* Horrible; stolen from pp.c:pp_subst */
  SV *self = *(SP - num_args + 1);
  GV *substr_method;
  SV *result;

  if(!sv_isobject(self))
    return (*real_pp_substr)(aTHX);

  substr_method = gv_fetchmeth(SvSTASH(SvRV(self)), "(substr", 7, 0);

  if(!substr_method)
    return (*real_pp_substr)(aTHX);

#ifdef OPpSUBSTR_REPL_FIRST
  if(PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
    /* This flag means that the replacement comes first, before num_args
     * Easiest is to push it as the 4th argument then call the method
     */
    SV *replacement = SP[-num_args];

    ENTER;
    SAVETMPS;

    PUSHMARK(SP-num_args);
    if(num_args < 3)
      XPUSHs(&PL_sv_undef);
    XPUSHs(replacement);
    PUTBACK;

    call_sv((SV*)GvCV(substr_method), G_SCALAR|G_DISCARD);

    FREETMPS;
    LEAVE;

    RETURN;
  }
#endif

  if(PL_op->op_flags & OPf_MOD || LVRET) {
    overload_substr_ctx *ctx;
    MAGIC *mg;

    Newx(ctx, 1, overload_substr_ctx);

    ctx->substr_method = (GV*)SvREFCNT_inc(substr_method);

    if(num_args == 3)
      ctx->length = SvREFCNT_inc(POPs);
    else
      ctx->length = NULL;

    ctx->offset = SvREFCNT_inc(POPs);
    POPs; /* self */

    result = sv_2mortal(newSVpvn("", 0));

    mg = sv_magicext(result, self, PERL_MAGIC_ext, &vtbl, (void *)ctx, 0);

    XPUSHs(result);
    RETURN;
  }

  ENTER;
  SAVETMPS;

  /* This piece of evil trickery "pushes" all the args we already have on the
   * stack, by simply claiming the MARK to be at the bottom of this op's args
   */
  PUSHMARK(SP-num_args);
  PUTBACK;

  call_sv((SV*)GvCV(substr_method), G_SCALAR);

  SPAGAIN;
  result = POPs;

  SvREFCNT_inc(result);

  FREETMPS;
  LEAVE;

  XPUSHs(result);

  RETURN;
}

MODULE = overload::substr       PACKAGE = overload::substr

BOOT:
if(!init_done++) {
  real_pp_substr = PL_ppaddr[OP_SUBSTR];
  PL_ppaddr[OP_SUBSTR] = &Perl_pp_overload_substr;
}