#define PERL_NO_GET_CONTEXT	/* we want efficiency */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"

#define MAGIC	1	/* Support magic */

#ifndef INFINITY
# ifdef HUGE_VAL
#  define INFINITY	((NV) HUGE_VAL)
# else /* HUGE_VAL */
#  define INFINITY	(NV_MAX*NV_MAX)
# endif /* HUGE_VAL */
#endif /* INFINITY */

#define MORTALCOPY(sv) sv_2mortal(newSVsv(sv))
#define MAX_SIZE	((size_t) -1)

enum order {
    LESS = 1,
    MORE,
    LT,
    GT,
    CODE_ORDER,
    MAX_ORDER
};

enum elements {
    SCALAR = 1,
    ARRAY,
    HASH,
    METHOD,
    OBJECT,
    FUNCTION,
    ANY_ELEM,
    MAX_ELEMENTS
};

typedef struct heap {
    SV **values;	/* The values the user stored in the heap */
    SV **keys;		/* The corresponding keys, but only if wrapped == 1 */
    SV *hkey;		/* An SV used in finding a key for a value.
                           E.g. the hash key for element type Hash */
    SV *order_sv;	/* Code reference to compare keys for the CODE order */
    SV *infinity;	/* The infinity for the given order, can be NULL */
    SV *user_data;	/* Associated data, only for the user */
    size_t used;	/* How many values/keys are used+1 (index 0 unused) */
    size_t allocated;	/* How many values/keys are allocated */
    size_t max_count;	/* Maximum heap size, MAX_SIZE means unlimited */
    I32 aindex;		/* A value used for indexing the key for a value */
    int wrapped;	/* True if keys are stored seperate from values */
    int fast;		/* True means that keys are scalars, not SV's */
    int has_values;	/* SV values in the SV array. False for fast scalars */
    int dirty;		/* "dirty" option was given and true */
    int can_die;	/* used to choose between mass-heapify or one-by-one */
    int key_ops;        /* key_insert, _key_insert and key_absorb will work */
    int locked;
    enum order order;	/* Which order is used */
    enum elements elements; /* Element type */
} *heap;

/*
    O: not filled in
    X: Filled in, but not an SV (only happens for keys, if and only if fast)
    *: Filled in with an SV     (if and only if has_values)

    Possible flag combinations:
    wrapped fast has_values KV
      0       0      0	          Impossible
      1       0      0		  Impossible
      0       1      0      XO    scalar dirty order
      1       1      0		  Impossible
      0       0      1      O*    Normal heap
      1       0      1      **    Object/Any heap
     (0       1      1      X*    normal heap with dirty order) # dropped
      1       1      1      X*    Object/Any heap with dirty order

      looks "wrapped" to the outside world for the last 3 cases
 */

typedef struct merge {
    SV *key;
    AV *array;
    I32 index;
} merge;

typedef struct fast_merge {
    AV *array;
    I32 index;
    NV key;
} fast_merge;

/* Workaround for older perls without packWARN */
#ifndef packWARN
# define packWARN(a) (a)
#endif

/* Duplicate from perl source (since it's not exported unfortunately) */
static bool my_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
                          int len, int level) {
    AV* av;
    GV* gv;
    GV** gvp;
    HV* hv = Nullhv;
    SV* subgen = Nullsv;

    /* A stash/class can go by many names (ie. User == main::User), so
       we compare the stash itself just in case */
    if ((name_stash && stash == name_stash) ||
        strEQ(HvNAME(stash), name) ||
        strEQ(name, "UNIVERSAL")) return TRUE;

    if (level > 100) croak("Recursive inheritance detected in package '%s'",
                           HvNAME(stash));

    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);

    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) &&
        (hv = GvHV(gv))) {
        if (SvIV(subgen) == (IV)PL_sub_generation) {
            SV* sv;
            SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
            if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
                DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
                                  name, HvNAME(stash)) );
                return sv == &PL_sv_yes;
            }
        } else {
            DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
                              HvNAME(stash)) );
            hv_clear(hv);
            sv_setiv(subgen, PL_sub_generation);
        }
    }

    gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);

    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
	if (!hv || !subgen) {
	    gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);

	    gv = *gvp;

	    if (SvTYPE(gv) != SVt_PVGV)
		gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);

	    if (!hv)
		hv = GvHVn(gv);
	    if (!subgen) {
		subgen = newSViv(PL_sub_generation);
		GvSV(gv) = subgen;
	    }
	}
	if (hv) {
	    SV** svp = AvARRAY(av);
	    /* NOTE: No support for tied ISA */
	    I32 items = AvFILLp(av) + 1;
	    while (items--) {
		SV* sv = *svp++;
		HV* basestash = gv_stashsv(sv, FALSE);
		if (!basestash) {
		    if (ckWARN(WARN_MISC))
			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                                    "Can't locate package %"SVf" for @%s::ISA",
                                    sv, HvNAME(stash));
		    continue;
		}
		if (my_isa_lookup(aTHX_ basestash, name, name_stash,
                                  len, level + 1)) {
		    (void)hv_store(hv,name,len,&PL_sv_yes,0);
		    return TRUE;
		}
	    }
	    (void)hv_store(hv,name,len,&PL_sv_no,0);
	}
    }
    return FALSE;
}

#define C_HEAP(object, context) c_heap(aTHX_ object, context)

static heap c_heap(pTHX_ SV *object, const char *context) {
    SV *sv;
    HV *stash, *class_stash;
    IV address;

    if (MAGIC) SvGETMAGIC(object);
    if (!SvROK(object)) {
        if (SvOK(object)) croak("%s is not a reference", context);
        croak("%s is undefined", context);
    }
    sv = SvRV(object);
    if (!SvOBJECT(sv)) croak("%s is not an object reference", context);
    stash = SvSTASH(sv);
    /* Is the next even possible ? */
    if (!stash) croak("%s is not a typed reference", context);
    class_stash = gv_stashpv("Heap::Simple::XS", FALSE);
    if (!my_isa_lookup(aTHX_ stash, "Heap::Simple::XS", class_stash, 16, 0))
        croak("%s is not a Heap::Simple::XS reference", context);
    address = SvIV(sv);
    if (!address)
        croak("Heap::Simple::XS object %s has a NULL pointer", context);
    return INT2PTR(heap, address);
}

#define TRY_C_HEAP(object) try_c_heap(aTHX_ &(object))

static heap try_c_heap(pTHX_ SV **object) {
    SV *sv;
    HV *stash, *class_stash;
    IV address;

    sv = *object;
    if (!SvROK(sv)) return NULL;
    sv = SvRV(sv);
    if (!SvOBJECT(sv)) return NULL;
    stash = SvSTASH(sv);
    /* Is the next even possible ? */
    if (!stash) return NULL;
    class_stash = gv_stashpv("Heap::Simple::XS", FALSE);
    if (!my_isa_lookup(aTHX_ stash, "Heap::Simple::XS", class_stash, 16,0))
        return NULL;
    address = SvIV(sv);
    if (!address) croak("Heap::Simple::XS object is a NULL pointer");
    *object = sv;
    return INT2PTR(heap, address);
}

static void extend(heap h, size_t min_extra) {
    min_extra += 3+h->used;
    h->allocated = 2*h->used;
    if (h->allocated < min_extra) h->allocated = min_extra;
    /* if (h->allocated > MAX_INT) croak("Allocation overflow"); */
    if (h->fast) {
        NV *tmp;
        tmp = (NV *) h->keys;
        Renew(tmp, h->allocated, NV);
        h->keys = (SV **) tmp;
        if (h->has_values) Renew(h->values, h->allocated, SV *);
    } else {
        if (h->wrapped) Renew(h->keys, h->allocated, SV *);
        Renew(h->values, h->allocated, SV *);
    }
}

/* target is lowercase, ends in 0, and lengths are already equal */
static int low_eq(const char *name, const char *target) {
    while (*target) {
        if (toLOWER(*name) != *target++) return 0;
        name++;
    }
    return 1;
}

static const char *elements_name(heap h) {
    switch(h->elements) {
      case SCALAR:   return "Scalar";
      case ARRAY:    return "Array";
      case HASH:     return "Hash";
      case METHOD:   return "Method";
      case OBJECT:   return "Object";
      case FUNCTION: return "Function";
      case ANY_ELEM: return "Any";
      case 0: croak("Element type is unspecified");
      default: croak("Assertion: Impossible element type %d", h->elements);
    }
    /* NOTREACHED */
    return NULL;
}

static const char *order_name(heap h) {
    switch(h->order) {
      case LESS: return "<";
      case MORE: return ">";
      case LT:   return "lt";
      case GT:   return "gt";
      case CODE_ORDER: return "CODE";
      case 0: croak("Order type is unspecified");
      default: croak("Assertion: Impossible order type %d", h->order);
    }
    /* NOTREACHED */
    return NULL;
}

/*  KEY only gets called if h->fast == 0 */
#define KEY(h, i) ((h)->wrapped ? (h)->keys[i] : fetch_key(aTHX_ (h),(h)->values[i]))
/* FKEY only gets called if h->fast == 1 */
#define FKEY(type, h, i)	(((type *)(h)->keys)[i])
/* key is returned with the refcount unincremented,
   key will not have get magic applied */
static SV *fetch_key(pTHX_ heap h, SV *value) {
    switch(h->elements) {
        AV *av;
        HV *hv;
        HE *he;
        SV **fetched, *key;
        I32 start, count;
      case SCALAR:
        return value;
      case ARRAY:
        /* mm, can a tied access change the stack base ? */
        if (!SvROK(value)) croak("Not a reference");
        av = (AV*) SvRV(value);
        if (SvTYPE(av) != SVt_PVAV) croak("Not an ARRAY reference");
        fetched = av_fetch(av, h->aindex, 0);
        return fetched ? *fetched : &PL_sv_undef;
      case HASH:
        if (!SvROK(value)) croak("Not a reference");
        hv = (HV*) SvRV(value);
        if (SvTYPE(hv) != SVt_PVHV) croak("Not a HASH reference");
        he = hv_fetch_ent(hv, h->hkey, 0, h->aindex);
        if (he) {
            /* HASH value for magical hashes seem to jump around */
            if (!h->aindex && !(MAGIC && SvMAGICAL(hv)))
                h->aindex = HeHASH(he);
            return HeVAL(he);
        } else {
            return &PL_sv_undef;
        }
      case OBJECT:
        if (!h->hkey) croak("Element type 'Object' without key method");
        /* FALLTHROUGH */
      case METHOD:
          {
              dSP;

              start = (SP) - PL_stack_base;
              PUSHMARK(SP);
              XPUSHs(value);
              PUTBACK;
              count = call_sv(h->hkey, G_SCALAR | G_METHOD);
              if (count != 1) croak("Forced scalar context call succeeded in returning %d values. This is impossible", (int) count);

              SPAGAIN;
              key = POPs;
              if (start != (SP) - PL_stack_base) croak("Stack base changed");
              PUTBACK;
              /* Stack is back, but can have been reallocated ! */
              return key;
          }
      case ANY_ELEM:
        if (!h->hkey) croak("Element type 'Any' without key code");
        /* FALLTHROUGH */
      case FUNCTION:
          {
              dSP;

              start = (SP) - PL_stack_base;
              PUSHMARK(SP);
              XPUSHs(value);
              PUTBACK;
              count = call_sv(h->hkey, G_SCALAR);
              if (count != 1) croak("Forced scalar context call succeeded in returning %d values. This is impossible", (int) count);

              SPAGAIN;
              key = POPs;
              if (start != (SP) - PL_stack_base) croak("Stack base changed");
              PUTBACK;
              /* Stack is back, but can have been reallocated ! */
              return key;
          }
      default:
        croak("fetch_key not implemented for element type '%s'",
              elements_name(h));
    }
    croak("fetch_key does not return for element type '%s'",
          elements_name(h));
    /* NOTREACHED */
    return NULL;
}

/* should be able to handle get magic if needed,
   but will normally be called without */
static int less(pTHX_ heap h, SV *l, SV *r) {
    SV *result;
    I32 start, count;
    dSP;

    start = (SP) - PL_stack_base;
    if (h->order == CODE_ORDER) { PUSHMARK(SP); }
    XPUSHs(l);
    XPUSHs(r);
    PUTBACK;
    switch(h->order) {
      case LESS:
        /* pp_lt(); */
        PL_ppaddr[OP_LT](aTHX);
        break;
      case MORE:
        /* pp_gt(); */
        PL_ppaddr[OP_GT](aTHX);
        break;
      case LT:
        /* pp_slt(); */
        PL_ppaddr[OP_SLT](aTHX);
        break;
      case GT:
        /* pp_sgt(); */
        PL_ppaddr[OP_SGT](aTHX);
        break;
      case CODE_ORDER:
        count = call_sv(h->order_sv, G_SCALAR);
        if (count != 1) croak("Forced scalar context call succeeded in returning %d values. This is impossible", (int) count);
        break;
      default:
        croak("less not implemented for order type '%s'", order_name(h));
    }
    SPAGAIN;
    result = POPs;
    if (start != (SP) - PL_stack_base) croak("Stack base changed");
    PUTBACK;
    /* warn("comparing %"NVff" to %"NVff" -> %d", SvNV(l), SvNV(r), SvTRUE(result) ? 1 : 0); */
    if      (result == &PL_sv_yes) return 1;
    else if (result == &PL_sv_no)  return 0;
    /* This can also happen for pp_lt and co in case the value is overloaded */
    /* SvTRUE does mg_get (through sv_2bool) */
    else return SvTRUE(result) ? 1 : 0;
}

/* key and value have refcount not increaded at call */
static void key_insert(pTHX_ heap h, SV *key, SV *value) {
    size_t p, pos, l, n;
    SV *new, *t1, *t2;
    int val_copied, key_copied;

    val_copied = 0;
    if (h->fast) {
        NV k;

        if (!key) {
            if (MAGIC && SvGMAGICAL(value)) {
                value = MORTALCOPY(value);
                val_copied = 1;
            }
            key = fetch_key(aTHX_ h, value);
        }
        /* SvNV will handle get magic (though sv_2nv) */
        if      (h->order == LESS) k =  SvNV(key);
        else if (h->order == MORE) k = -SvNV(key);
        else croak("No fast %s order", order_name(h));

        if (h->used > h->max_count) {
            NV key1, key2;
            if (h->used < 2 || k <= FKEY(NV, h, 1)) return;
            /* Drop the old top and percolate the new value down */
            /* This is almost completely identical to extract_top, but
               I don't see a clean way to factor it out that preserves
               resistance agains crashes of less/fetch_key */
            n = h->used-1;
            l = 2;

            if (h->has_values) {
                new = val_copied ? SvREFCNT_inc(value) : newSVsv(value);
                t1 = h->values[1];
            }

            while (l < n) {
                key1 = FKEY(NV, h, l);
                key2 = FKEY(NV, h, l+1);
                if (key1 < k) {
                    if (key2 < key1) {
                        FKEY(NV, h, l/2) = key2;
                        l++;
                    } else {
                        FKEY(NV, h, l/2) = key1;
                    }
                } else if (key2 < k) {
                    FKEY(NV, h, l/2) = key2;
                    l++;
                } else break;
                if (h->has_values) h->values[l/2] = h->values[l];
                l *= 2;
            }
            if (l == n) {
                key1 = FKEY(NV, h, l);
                if (key1 < k) {
                    FKEY(NV, h, l/2) = key1;
                    if (h->has_values) h->values[l/2] = h->values[l];
                    l*= 2;
                }
            }
            l /= 2;
            FKEY(NV, h, l) = k;
            if (h->has_values) {
                h->values[l] = new;
                SvREFCNT_dec(t1);
            }
            return;
        }

        pos = h->used;
        if (h->used >= h->allocated) extend(h, 1);
        FKEY(NV, h, 0) = k;
        if (h->has_values) {
            new = val_copied ? SvREFCNT_inc(value) : newSVsv(value);
            while (k < (FKEY(NV, h, pos) = FKEY(NV, h, pos >> 1))) {
                h->values[pos] = h->values[pos >> 1];
                pos >>= 1;
            }
            h->values[pos] = new;
        } else
            while (k < (FKEY(NV, h, pos) = FKEY(NV, h, pos >> 1))) pos >>= 1;
        FKEY(NV, h, pos) = k;
        h->used++;
        return;
    }

    /* h->fast == 0 */
    if (h->used < 2) {
        /* Handled seperately in order to avoid an unneeded key fetch */
        if (h->used != 1) croak("Assertion: negative sized heap");
        if (h->max_count < 1) return;
        if (h->allocated <= 1) extend(h, 1);
        if (h->wrapped) {
            if (!key) {
                if (MAGIC && SvGMAGICAL(value)) {
                    value = MORTALCOPY(value);
                    val_copied = 1;
                }
                key = fetch_key(aTHX_ h, value);
            }
            /* newSVsv does get magic */
            h->keys[1] = newSVsv(key);
        }
        h->values[1] = val_copied ? SvREFCNT_inc(value) : newSVsv(value);
        h->used = 2;
        return;
    }

    /* We are certain we will need the key now. Fetch it. */
    if (!key) {
        if (MAGIC && SvGMAGICAL(value)) {
            value = MORTALCOPY(value);
            val_copied = 1;
        }
        key = fetch_key(aTHX_ h, value);
    }
    if (MAGIC && SvGMAGICAL(key)) {
        key = MORTALCOPY(key);
        key_copied = 1;
    } else key_copied = 0;

    if (h->used > h->max_count) {
        SV *key1, *key2;
        if (!less(aTHX_ h, KEY(h, 1), key)) return;
        /* Drop the old top and percolate the new value down */
        /* This is almost completely identical to extract_top, but
           I don't see a clean way to factor it out that preserves
           resistance agains exceptions in less/fetch_key */

        n = h->used-1;
        l = 2;

        while (l < n) {
            key1 = KEY(h, l);
            if (MAGIC && SvGMAGICAL(key1)) key1 = MORTALCOPY(key1);
            key2 = KEY(h, l+1);
            if (less(aTHX_ h, key1, key)) {
                if (less(aTHX_  h, key2, key1)) l++;
            } else if (less(aTHX_ h, key2, key)) l++;
            else break;
            l *= 2;
        }
        if (l == n) {
            key1 = KEY(h, l);
            if (less(aTHX_ h, key1, key)) l*= 2;
        }
        l /= 2;

        t1 = val_copied ? SvREFCNT_inc(value) : newSVsv(value);
        if (h->wrapped) {
            /* Assume newSVsv can't die since key will already have been
               (mortal)copied in case it's magic */
            key1 = key_copied ? SvREFCNT_inc(key) : newSVsv(key);
            while (l >= 1) {
                key2 = h->keys[l];
                t2   = h->values[l];
                h->keys[l] = key1;
                h->values[l] = t1;
                key1 = key2;
                t1 = t2;
                l /= 2;
            }
            SvREFCNT_dec(key1);
        } else {
            while (l >= 1) {
                t2 = h->values[l];
                h->values[l] = t1;
                t1 = t2;
                l /= 2;
            }
        }
        SvREFCNT_dec(t1);
        return;
    }
    pos = h->used;

    while (pos > 1 && less(aTHX_ h, key, KEY(h, pos/2))) pos /= 2;
    if (h->used >= h->allocated) extend(h, 1);
    new = val_copied ? SvREFCNT_inc(value) : newSVsv(value);
    if (h->wrapped) {
        /* Assume newSVsv can't die since key will already have been
           (mortal)copied in case it's magic */
        key = key_copied ? SvREFCNT_inc(key) : newSVsv(key);
        for (p=h->used; p != pos; p/=2) {
            h->keys[p]   = h->keys[p/2];
            h->values[p] = h->values[p/2];
        }
        h->keys[pos] = key;
    } else {
        for (p=h->used; p != pos; p/=2) h->values[p] = h->values[p/2];
    }
    h->values[pos] = new;
    h->used++;
}

static void multi_insert(pTHX_ heap h, size_t first) {
    size_t i;
    SV *value;

    /* Shut up warnings */
    value = NULL;

    if (h->fast) {
        NV k, key1, key2;
        size_t n, l;

        n = h->used-1;
        for (i = n/2; i>= first; i--) {
            if (h->has_values) value = h->values[i];
            k = FKEY(NV, h, i);
            l = i*2;
            while (l < n) {
                key1 = FKEY(NV, h, l);
                key2 = FKEY(NV, h, l+1);
                if (key1 < k) {
                    if (key2 < key1) {
                        FKEY(NV, h, l/2) = key2;
                        l++;
                    } else {
                        FKEY(NV, h, l/2) = key1;
                    }
                } else if (key2 < k) {
                    FKEY(NV, h, l/2) = key2;
                    l++;
                } else break;
                if (h->has_values) h->values[l/2] = h->values[l];
                l *= 2;
            }
            if (l == n) {
                key1 = FKEY(NV, h, l);
                if (key1 < k) {
                    FKEY(NV, h, l/2) = key1;
                    if (h->has_values) h->values[l/2] = h->values[l];
                    l*= 2;
                }
            }
            l /= 2;
            if (h->has_values) h->values[l] = value;
            FKEY(NV, h, l) = k;
        }
        /* i is now points to the highest numbered old entry that needs to
           be percolated */
        first /= 2;
        if (first < 1) first = 1;
        /* the range [first..i] MUST be percolated */
        if (i >= first) {
            size_t *todo, *old_to, *new_to, *here;
            New(__LINE__ % 1000, todo, i-first+2, size_t);
            new_to = todo;
            todo++;
            while (i >= first) *++new_to = i--;

            while (new_to >= todo) {
                old_to = new_to;
                new_to = todo-1;
                *new_to = *old_to;
                for (here = todo; here <= old_to; here++) {
                    i = *here;
                    if (h->has_values) value = h->values[i];
                    k = FKEY(NV, h, i);
                    l = i*2;
                    while (l < n) {
                        key1 = FKEY(NV, h, l);
                        key2 = FKEY(NV, h, l+1);
                        if (key1 < k) {
                            if (key2 < key1) {
                                FKEY(NV, h, l/2) = key2;
                                l++;
                            } else {
                                FKEY(NV, h, l/2) = key1;
                            }
                        } else if (key2 < k) {
                            FKEY(NV, h, l/2) = key2;
                            l++;
                        } else break;
                        if (h->has_values) h->values[l/2] = h->values[l];
                        l *= 2;
                    }
                    if (l == n) {
                        key1 = FKEY(NV, h, l);
                        if (key1 < k) {
                            FKEY(NV, h, l/2) = key1;
                            if (h->has_values) h->values[l/2] = h->values[l];
                            l*= 2;
                        }
                    }
                    l /= 2;
                    if (h->has_values) h->values[l] = value;
                    FKEY(NV, h, l) = k;
                    /* Did entry i change ? */
                    if (l != i && i/2 < *new_to && i >= 2) *++new_to = i/2;
                }
            }
            todo--;
            Safefree(todo);
        }
    } else {
        SV *k, *key1, *key2;
        size_t n, l;

        n = h->used-1;
        for (i = n/2; i>= first; i--) {
            k = KEY(h, i);
            value = h->values[i];
            l = i*2;
            while (l < n) {
                key1 = KEY(h, l);
                key2 = KEY(h, l+1);
                if (less(aTHX_ h, key1, k)) {
                    if (less(aTHX_ h, key2, key1)) {
                        if (h->wrapped) h->keys[l/2] = key2;
                        l++;
                    } else {
                        if (h->wrapped) h->keys[l/2] = key1;
                    }
                } else if (less(aTHX_ h, key2, k)) {
                    if (h->wrapped) h->keys[l/2] = key2;
                    l++;
                } else break;
                h->values[l/2] = h->values[l];
                l *= 2;
            }
            if (l == n) {
                key1 = KEY(h, l);
                if (less(aTHX_ h, key1, k)) {
                    if (h->wrapped) h->keys[l/2] = key1;
                    h->values[l/2] = h->values[l];
                    l*= 2;
                }
            }
            l /= 2;
            h->values[l] = value;
            if (h->wrapped) h->keys[l] = k;
        }
        /* i is now points to the highest numbered old entry that needs to
           be percolated */
        first /= 2;
        if (first < 1) first = 1;
        /* the range [first..i] MUST be percolated */
        if (i >= first) {
            size_t *todo, *old_to, *new_to, *here;
            New(__LINE__ % 1000, todo, i-first+2, size_t);
            SAVEFREEPV(todo);
            new_to = todo;
            todo++;
            while (i >= first) *++new_to = i--;

            while (new_to >= todo) {
                old_to = new_to;
                new_to = todo-1;
                *new_to = *old_to;
                for (here = todo; here <= old_to; here++) {
                    i = *here;
                    value = h->values[i];
                    k = KEY(h, i);
                    l = i*2;
                    while (l < n) {
                        key1 = KEY(h, l);
                        key2 = KEY(h, l+1);
                        if (less(aTHX_ h, key1, k)) {
                            if (less(aTHX_ h, key2, key1)) {
                                if (h->wrapped) h->keys[l/2] = key2;
                                l++;
                            } else {
                                if (h->wrapped) h->keys[l/2] = key1;
                            }
                        } else if (less(aTHX_ h, key2, k)) {
                            if (h->wrapped) h->keys[l/2] = key2;
                            l++;
                        } else break;
                        h->values[l/2] = h->values[l];
                        l *= 2;
                    }
                    if (l == n) {
                        key1 = KEY(h, l);
                        if (less(aTHX_ h, key1, k)) {
                            if (h->wrapped) h->keys[l/2] = key1;
                            h->values[l/2] = h->values[l];
                            l*= 2;
                        }
                    }
                    l /= 2;
                    h->values[l] = value;
                    if (h->wrapped) h->keys[l] = k;
                    /* Did entry i change ? */
                    if (l != i && i/2 < *new_to && i >= 2) *++new_to = i/2;
                }
            }
        }
    }
}

/* Returns the top value with the refcount still increased
   Only to be called if there is at least element, so with h->used >= 2
   The non-fast version uses the stack, so wrap in PUTBACK/SPAGAIN ! */
static SV *extract_top(pTHX_ heap h) {
    SV *t1, *t2;
    size_t l, n;

    n = h->used-2;
    l = 2;

    if (h->fast) {
        NV key, key1, key2;

        key = FKEY(NV, h, --h->used);
        if (h->has_values) t1 = h->values[1];
        else if (h->order == LESS) t1 = newSVnv( FKEY(NV, h, 1));
        else if (h->order == MORE) t1 = newSVnv(-FKEY(NV, h, 1));
        else croak("No fast %s order", order_name(h));

        while (l < n) {
            key1 = FKEY(NV, h, l);
            key2 = FKEY(NV, h, l+1);
            if (key1 < key) {
                if (key2 < key1) {
                    FKEY(NV, h, l/2) = key2;
                    l++;
                } else {
                    FKEY(NV, h, l/2) = key1;
                }
            } else if (key2 < key) {
                FKEY(NV, h, l/2) = key2;
                l++;
            } else break;
            if (h->has_values) h->values[l/2] = h->values[l];
            l *= 2;
        }
        if (l == n) {
            key1 = FKEY(NV, h, l);
            if (key1 < key) {
                FKEY(NV, h, l/2) = key1;
                if (h->has_values) h->values[l/2] = h->values[l];
                l*= 2;
            }
        }
        l /= 2;
        FKEY(NV, h, l) = key;
        if (h->has_values) h->values[l] = h->values[h->used];
    } else {
        SV *key, *key1, *key2;

        key = KEY(h, h->used-1);
        while (l < n) {
            key1 = KEY(h, l);
            if (MAGIC && SvGMAGICAL(key1)) key1 = MORTALCOPY(key1);
            key2 = KEY(h, l+1);
            if (less(aTHX_ h, key1, key)) {
                if (less(aTHX_  h, key2, key1)) l++;
            } else if (less(aTHX_ h, key2, key)) l++;
            else break;
            l *= 2;
        }
        if (l == n) {
            key1 = KEY(h, l);
            if (less(aTHX_ h, key1, key)) l*= 2;
        }
        l /= 2;

        t1 = h->values[--h->used];
        if (h->wrapped) {
            key1 = h->keys[h->used];
            while (l >= 1) {
                key2 = h->keys[l];
                t2 = h->values[l];
                h->keys[l] = key1;
                h->values[l] = t1;
                key1 = key2;
                t1 = t2;
                l /= 2;
            }
            SvREFCNT_dec(key1);
        } else {
            while (l >= 1) {
                t2 = h->values[l];
                h->values[l] = t1;
                t1 = t2;
                l /= 2;
            }
        }
    }
    return t1;
}

static void reverse(heap h, size_t bottom, size_t top) {
    while (top > bottom) {
        SV *value, *key;

        if (h->has_values) {
            value = h->values[top];
            h->values[top] = h->values[bottom];
            h->values[bottom] = value;
        }

        if (h->fast) {
            NV k;
            k = FKEY(NV, h, top);
            FKEY(NV, h, top) = FKEY(NV, h, bottom);
            FKEY(NV, h, bottom) = k;
        } else if (h->wrapped) {
            key = h->keys[top];
            h->keys[top] = h->keys[bottom];
            h->keys[bottom] = key;
        }

        top--;
        bottom++;
    }
}

static void option(pTHX_ heap h, SV *tag, SV *value) {
    STRLEN len;
    /* SvPV does magic fetch */
    char *name = SvPV(tag, len);
    if (len >= 5) switch(name[0]) {
      case 'c':
        if (len == 7 && strEQ(name, "can_die")) {
            /* SvTRUE does mg_get (through sv_2bool) */
            h->can_die = SvTRUE(value);
            return;
        }
        break;
      case 'd':
        if (len == 5 && strEQ(name, "dirty")) {
            if (h->dirty) croak("Multiple dirty options");
            /* SvTRUE does mg_get (through sv_2bool) */
            h->dirty = SvTRUE(value) ? 1 : -1;
            return;
        }
        break;
      case 'e':
        if (len == 8 && strEQ(name, "elements")) {
            if (h->elements) croak("Multiple elements options");
            if (MAGIC) SvGETMAGIC(value);
            if (SvROK(value)) {
                /* Some sort of reference */
                AV *av;
                SV **fetched;

                av = (AV*) SvRV(value);
                if (SvTYPE(av) != SVt_PVAV)
                    croak("option elements is not an array reference");
                fetched = av_fetch(av, 0, 0);
                /* SvPV will do get magic */
                if (fetched) name = SvPV(*fetched, len);
                if (!fetched || !SvOK(*fetched))
                    croak("option elements has no type defined at index 0");
                if ((len == 6 && low_eq(name, "scalar")) ||
                    (len == 3 && low_eq(name, "key"))) {
                    if (av_len(av) > 0)
                        warn("Extra arguments to Scalar ignored");
                    h->elements = SCALAR;
                } else if (len == 5 && low_eq(name, "array")) {
                    h->elements = ARRAY;
                    if (av_len(av) > 0) {
                        SV **pindex, *index;
                        IV i;
                        if (av_len(av) > 1) warn("Extra arguments to Array ignored");
                        pindex = av_fetch(av, 1, 0);
                        /* SvIV will do get magic (through sv_2iv) */
                        index = pindex ? *pindex : &PL_sv_undef;
                        h->aindex = i = SvIV(index);
                        if (i != h->aindex)
                            croak("Index overflow of %"IVdf, i);
                    } else h->aindex = 0;
                } else if (len == 4 && low_eq(name, "hash")) {
                    SV **index;
                    h->elements = HASH;
                    if (av_len(av) < 1)
                        croak("missing key name for %"SVf, *fetched);
                    if (av_len(av) > 1)
                        warn("Extra arguments to Hash ignored");
                    index = av_fetch(av, 1, 0);
                    if (h->hkey)
                        croak("Assertion: already have a hash key");
                    /* newSVsv will do get magic */
                    if (index) h->hkey = newSVsv(*index);
                    if (!index || !SvOK(*index))
                        croak("missing key name for %"SVf, *fetched);
                    h->aindex = 0;
                } else if (len == 6 && (low_eq(name, "method") ||
                                        low_eq(name, "object"))) {
                    SV **index;
                    if (toLOWER(name[0]) == 'm') {
                        h->elements = METHOD;
                        if (av_len(av) < 1)
                            croak("missing key method for %"SVf, *fetched);
                    } else {
                        h->elements = OBJECT;
                        h->wrapped  = 1;
                        if (av_len(av) < 1) return;
                    }
                    if (av_len(av) > 1)
                        warn("Extra arguments to %"SVf" ignored", *fetched);
                    index = av_fetch(av, 1, 0);
                    if (h->hkey)
                        croak("Assertion: already have a method name");
                    /* newSVsv will do get magic */
                    if (index) h->hkey = newSVsv(*index);
                    if (!index || !SvOK(*index))
                        croak("missing key method for %"SVf, *fetched);
                } else if ((len == 8 && low_eq(name, "function")) ||
                           (len == 3 && low_eq(name, "any"))) {
                    SV **index;
                    if (toLOWER(name[0]) == 'f') {
                        h->elements = FUNCTION;
                        if (av_len(av) < 1)
                            croak("missing key function for %"SVf, *fetched);
                    } else {
                        h->elements = ANY_ELEM;
                        h->wrapped  = 1;
                        if (av_len(av) < 1) return;
                    }
                    if (av_len(av) > 1)
                        warn("Extra arguments to %"SVf" ignored", *fetched);
                    index = av_fetch(av, 1, 0);
                    if (h->hkey)
                        croak("Assertion: already have a key function");
                    /* Don't check if it's actually a code ref.
                       Allow unstrict name based call, or garbage that
                       never gets used */
                    /* newSVsv will do get magic */
                    if (index) h->hkey = newSVsv(*index);
                    if (!index || !SvOK(*index))
                        croak("missing key function for %"SVf, *fetched);
                } else croak("Unknown element type '%"SVf"'", *fetched);
            } else {
                name = SvPV(value, len);
                if      ((len == 6 && low_eq(name, "scalar")) ||
                          (len == 3 && low_eq(name, "key")))
                    h->elements = SCALAR;
                else if (len == 5 && low_eq(name, "array")) {
                    h->elements = ARRAY;
                    h->aindex = 0;
                } else if (len == 6 && low_eq(name, "object")) {
                    h->elements = OBJECT;
                    h->wrapped  = 1;
                } else if (len == 3 && low_eq(name, "any")) {
                    h->elements = ANY_ELEM;
                    h->wrapped  = 1;
                } else if (len == 4 && low_eq(name, "hash"))
                    croak("missing key name for %"SVf, value);
                else if(len == 6 && low_eq(name, "method"))
                    croak("missing key method for %"SVf, value);
                else if (len == 8 && low_eq(name, "function"))
                    croak("missing key function for %"SVf, value);
                else croak("Unknown element type '%"SVf"'", value);
            }
            return;
        }
        break;
      case 'i':
        if (len == 8 && strEQ(name, "infinity")) {
            if (h->infinity) croak("Multiple infinity options");
            h->infinity = newSVsv(value);
            return;
        }
        break;
      case 'm':
        if (len == 9 && strEQ(name, "max_count")) {
            NV max_count;
            size_t m;
            if (h->max_count != MAX_SIZE) croak("Multiple max_count options");
            max_count = SvNV(value);
            if (max_count < 0) croak("max_count should not be negative");
            if (max_count == INFINITY) return;
            if (max_count >= MAX_SIZE)
                croak("max_count too big. Use infinity instead");
            m = (size_t) max_count;
            if (m != max_count) croak("max_count should be an integer");
            h->max_count = m;
            return;
        }
        break;
      case 'o':
        if (len == 5 && strEQ(name, "order")) {
            if (h->order) croak("Multiple order options");
            /* SvPV does get magic */
            name = SvPV(value, len);
            if (SvROK(value)) {
                /* Some sort of reference */
                SV *cv = SvRV(value);
                if (SvTYPE(cv) != SVt_PVCV)
                    croak("order value is a reference but not a code reference");
                h->order = CODE_ORDER;
                h->order_sv = newRV_inc(cv);
                return;
            }
            if      (len == 1 && name[0] == '<') h->order = LESS;
            else if (len == 1 && name[0] == '>') h->order = MORE;
            else if (len == 2 && low_eq(name, "lt")) h->order = LT;
            else if (len == 2 && low_eq(name, "gt")) h->order = GT;
            else croak("Unknown order '%"SVf"'", value);
            return;
        }
        break;
      case 'u':
        if (len == 9 && strEQ(name, "user_data")) {
            if (h->user_data) croak("Multiple user_data options");
            h->user_data = newSVsv(value);
            return;
        }
        break;
    }
    croak("Unknown option '%"SVf"'", tag);
}

MODULE = Heap::Simple::XS		PACKAGE = Heap::Simple::XS
PROTOTYPES: ENABLE

SV *
new(char *class, ...)
  PREINIT:
    heap h;
    I32 i;
  CODE:
    if (items % 2 == 0) croak("Odd number of elements in options");
    New(__LINE__, h, 1, struct heap);
    h->keys = h->values = NULL;
    h->hkey = h->infinity = h->user_data = h->order_sv = NULL;
    h->allocated = 0;
    h->used = 1;
    h->wrapped = 0;
    h->order = 0;
    h->elements = 0;
    h->fast = 0;
    h->has_values = 1;
    h->can_die = 0;
    h->max_count = -1;
    h->dirty = 0;
    h->locked = 0;
    RETVAL = sv_newmortal();
    sv_setref_pv(RETVAL, class, (void*) h);

    for (i=1; i<items; i+=2) option(aTHX_ h, ST(i), ST(i+1));

    if (!h->order) h->order = LESS;
    if (!h->infinity) switch(h->order) {
      case LESS: h->infinity = newSVnv( INFINITY); break;
      case MORE: h->infinity = newSVnv(-INFINITY); break;
      case GT:   h->infinity = newSVpvn("", 0);         break;
      case LT: case CODE_ORDER: break;
      default:
        croak("Assertion: No infinity handler for order '%s'",
              order_name(h));
    }
    if (!h->elements) h->elements = SCALAR;
    if (h->dirty < 0) h->dirty = 0;

    /* FUNCTION and METHOD are excluded for the simple reason that if you want
       caching with them, you could use Any and Object instead */
    if (h->dirty && (h->order == LESS || h->order == MORE) &&
        (h->elements != FUNCTION && h->elements != METHOD)) h->fast = 1;
    if (h->fast && h->order != LESS && h->order != MORE)
        croak("No fast %s order", order_name(h));
    if (h->fast && h->elements == SCALAR) h->has_values = 0;
    h->key_ops = h->wrapped || (h->fast && h->has_values);
    /* Can't happen, but let's just make sure */
    if (h->wrapped && !h->has_values)
        croak("Assertion: wrapped but no has_values");
    SvREFCNT_inc(RETVAL);
  OUTPUT:
    RETVAL

UV
count(heap h)
  CODE:
    RETVAL = h->used-1;
  OUTPUT:
    RETVAL

void
insert(heap h, ...)
  PREINIT:
    I32 i, more;
    SV *key, *value;
    size_t first;
  CODE:
    if (h->locked) croak("recursive heap change");
    SAVEINT(h->locked);
    h->locked = 1;
    PUTBACK;
    i = 1;
    more = h->used-1+items-1 > h->max_count ?
	h->max_count-(h->used-1) : items-1;
    if (more > 1 && !h->can_die) {
        if (h->used+more > h->allocated) extend(h, more);
        first = h->used;
        if (h->fast) {
            NV k;

            for (; i<more; i++) {
                int val_copied;

                value = ST(i);
                if (MAGIC && SvGMAGICAL(value)) {
                    value = MORTALCOPY(value);
                    val_copied = 1;
                } else val_copied = 0;

                key = fetch_key(aTHX_ h, value);
                /* SvNV will handle get magic (though sv_2nv) */
                if      (h->order == LESS) k =  SvNV(key);
                else if (h->order == MORE) k = -SvNV(key);
                else croak("No fast %s order", order_name(h));

                FKEY(NV, h, h->used) = k;
                if (h->has_values)
                    h->values[h->used] = val_copied ?
                        SvREFCNT_inc(value) : newSVsv(value);
                h->used++;
            }
        } else {
            for (; i<more; i++) {
                value = ST(i);
                if (h->wrapped) {
                    int val_copied, key_copied;

                    if (MAGIC && SvGMAGICAL(value)) {
                        value = MORTALCOPY(value);
                        val_copied = 1;
                    } else val_copied = 0;

                    key = fetch_key(aTHX_ h, value);
                    if (MAGIC && SvGMAGICAL(key)) {
                        key = MORTALCOPY(key);
                        key_copied = 1;
                    } else key_copied = 0;
                    h->values[h->used] =
                        val_copied ? SvREFCNT_inc(value) : newSVsv(value);
                    /* Assume newSVsv can't die since key will already
                       have been (mortal)copied in case it's magic */
                    h->keys[h->used] = key_copied ?
                        SvREFCNT_inc(key) : newSVsv(key);
                } else h->values[h->used] = newSVsv(value);

                h->used++;
            }
        }
        multi_insert(aTHX_ h, first);
    }
    for (; i<items; i++) key_insert(aTHX_ h, NULL, ST(i));
    XSRETURN_EMPTY;

void
key_insert(heap h, ...)
  PREINIT:
    I32 i, more;
    SV *key, *value;
    size_t first;
  CODE:
    if (!h->key_ops) croak("This heap type does not support key_insert");
    if (items % 2 == 0) croak("Odd number of arguments");
    if (h->locked) croak("recursive heap change");
    SAVEINT(h->locked);
    h->locked = 1;
    PUTBACK;

    i = 1;
    more = h->used-1+items/2 > h->max_count ?
	h->max_count-(h->used-1) : items/2;
    if (more > 1 && !h->can_die) {
        if (h->used+more > h->allocated) extend(h, more);
        more = 2*more+1;
        first = h->used;
        if (h->fast) {
            NV k;

            for (; i<more; i+=2) {
                int val_copied;

                value = ST(i+1);

                if (MAGIC && SvGMAGICAL(value)) {
                    value = MORTALCOPY(value);
                    val_copied = 1;
                } else val_copied = 0;

                key = ST(i);
                /* SvNV will handle get magic (though sv_2nv) */
                if      (h->order == LESS) k =  SvNV(key);
                else if (h->order == MORE) k = -SvNV(key);
                else croak("No fast %s order", order_name(h));

                FKEY(NV, h, h->used) = k;
                if (h->has_values)
                    h->values[h->used] = val_copied ?
                        SvREFCNT_inc(value) : newSVsv(value);
                h->used++;
            }
        } else {
            if (!h->wrapped) croak("Assertion: slow non-wrapped key_ops");
            for (; i<more; i+=2) {
                int val_copied, key_copied;

                value = ST(i+1);

                if (MAGIC && SvGMAGICAL(value)) {
                    value = MORTALCOPY(value);
                    val_copied = 1;
                } else val_copied = 0;

                key = ST(i);
                if (MAGIC && SvGMAGICAL(key)) {
                    key = MORTALCOPY(key);
                    key_copied = 1;
                } else key_copied = 0;
                h->values[h->used] = val_copied ?
                    SvREFCNT_inc(value) : newSVsv(value);
                /* Assume newSVsv can't die since key will already
                   have been (mortal)copied in case it's magic */
                h->keys[h->used] = key_copied ?
                    SvREFCNT_inc(key) : newSVsv(key);

                h->used++;
            }
        }
        multi_insert(aTHX_ h, first);
    }
    for (; i<items; i+=2) key_insert(aTHX_ h, ST(i), ST(i+1));
    XSRETURN_EMPTY;

void
_key_insert(heap h, ...)
  PREINIT:
    AV *av;
    SV *key, *value, **key_ref, **val_ref, *pair;
    I32 i, more;
    size_t first;
  CODE:
    if (!h->key_ops) croak("This heap type does not support _key_insert");
    if (h->locked) croak("recursive heap change");
    SAVEINT(h->locked);
    h->locked = 1;
    PUTBACK;
    i = 1;
    more = h->used-1+items-1 > h->max_count ?
	h->max_count-(h->used-1) : items-1;
    if (more > 1 && !h->can_die) {
        if (h->used+more > h->allocated) extend(h, more);
        first = h->used;
        if (!h->fast && !h->wrapped)
            croak("Assertion: slow non-wrapped key_ops");
        for (; i<more; i++) {
            pair = ST(i);
            if (MAGIC) SvGETMAGIC(pair);
            if (!SvROK(pair)) croak("pair is not a reference");
            av = (AV*) SvRV(pair);
            if (SvTYPE(av) != SVt_PVAV) croak("pair is not an ARRAY reference");
            key_ref = av_fetch(av, 0, 0);
            if (!key_ref) croak("No key in the element array");
            key = *key_ref;
            val_ref = av_fetch(av, 1, 0);
            if (!val_ref) croak("No value in the element array");
            value = *val_ref;

            if (h->fast) {
                NV k;
                int val_copied;

                if (MAGIC && SvGMAGICAL(value)) {
                    value = MORTALCOPY(value);
                    val_copied = 1;
                } else val_copied = 0;

                /* SvNV will handle get magic (though sv_2nv) */
                if      (h->order == LESS) k =  SvNV(key);
                else if (h->order == MORE) k = -SvNV(key);
                else croak("No fast %s order", order_name(h));

                FKEY(NV, h, h->used) = k;
                if (h->has_values)
                    h->values[h->used] =
                        val_copied ? SvREFCNT_inc(value) : newSVsv(value);
            } else {
                int val_copied, key_copied;

                if (MAGIC && SvGMAGICAL(value)) {
                    value = MORTALCOPY(value);
                    val_copied = 1;
                } else val_copied = 0;

                if (MAGIC && SvGMAGICAL(key)) {
                    key = MORTALCOPY(key);
                    key_copied = 1;
                } else key_copied = 0;
                h->values[h->used] =
                    val_copied ? SvREFCNT_inc(value) : newSVsv(value);
                /* Assume newSVsv can't die since key will already
                   have been (mortal)copied in case it's magic */
                h->keys[h->used] = key_copied ?
                    SvREFCNT_inc(key) : newSVsv(key);
            }
            h->used++;
        }
        multi_insert(aTHX_ h, first);
    }
    for (; i<items; i++) {
        pair = ST(i);
        if (MAGIC) SvGETMAGIC(pair);
        if (!SvROK(pair)) croak("pair is not a reference");
        av = (AV*) SvRV(pair);
        if (SvTYPE(av) != SVt_PVAV) croak("pair is not an ARRAY reference");
        key_ref = av_fetch(av, 0, 0);
        if (!key_ref) croak("No key in the element array");
        val_ref = av_fetch(av, 1, 0);
        if (!val_ref) croak("No value in the element array");

        key_insert(aTHX_ h, *key_ref, *val_ref);
    }
    XSRETURN_EMPTY;

void
extract_top(heap h)
  ALIAS:
    Heap::Simple::XS::extract_min   = 1
    Heap::Simple::XS::extract_first = 2
  PPCODE:
    if (h->used <= 2) {
        if (h->used < 2) {
            if (ix != 2) croak("Empty heap");
            XSRETURN_EMPTY;
        }
        if (h->locked) croak("recursive heap change");
        SAVEINT(h->locked);
        h->locked = 1;
        --h->used;
        if (h->wrapped && !h->fast) SvREFCNT_dec(h->keys[h->used]);
        if (h->has_values) PUSHs(sv_2mortal(h->values[h->used]));
        else if (h->order == LESS) XSRETURN_NV( FKEY(NV, h, 1));
        else if (h->order == MORE) XSRETURN_NV(-FKEY(NV, h, 1));
        else croak("No fast %s order", order_name(h));
    } else {
        PUTBACK;
        if (h->locked) croak("recursive heap change");
        SAVEINT(h->locked);
        h->locked = 1;
        PUSHs(sv_2mortal(extract_top(aTHX_ h)));
    }

void
extract_upto(heap h, SV *border)
  PPCODE:
    /* special case, avoid uneeded access to border */
    if (h->used < 2) return;
    if (h->locked) croak("recursive heap change");
    SAVEINT(h->locked);
    h->locked = 1;
    if (h->fast) {
        NV b;
        if      (h->order == LESS) b =  SvNV(border);
        else if (h->order == MORE) b = -SvNV(border);
        else croak("No fast %s order", order_name(h));
        while (FKEY(NV, h, 1) <= b) {
            /* No PUTBACK/SPAGAIN needed since fast extract top
               won't change the stack */
            XPUSHs(sv_2mortal(extract_top(aTHX_ h)));
            if (h->used < 2) break;
        }
    } else {
        if (MAGIC && SvGMAGICAL(border)) border = MORTALCOPY(border);
        while (1) {
            SV *top;

            PUTBACK;
            if (less(aTHX_ h, border, KEY(h, 1))) {
                SPAGAIN;
                break;
            }
            top = extract_top(aTHX_ h);
            SPAGAIN;
            XPUSHs(sv_2mortal(top));
            if (h->used < 2) break;
        }
    }
    if ((h->used+4)*4 < h->allocated) extend(h, 0); /* shrink really */

void
extract_all(heap h)
  PPCODE:
    if (h->locked) croak("recursive heap change");
    SAVEINT(h->locked);
    h->locked = 1;
    /* Extends one too much. Who cares... */
    EXTEND(SP, h->used);
    EXTEND_MORTAL(h->used);
    if (h->fast) {
        /* No PUTBACK/SPAGAIN needed since fast extract top
           won't change the stack */
        while (h->used >= 2) XPUSHs(sv_2mortal(extract_top(aTHX_ h)));
    } else while (h->used >= 2) {
        SV *top;

        PUTBACK;
        top = extract_top(aTHX_ h);
        SPAGAIN;
        XPUSHs(sv_2mortal(top));
    }
    if ((1+4)*4 < h->allocated) extend(h, 0); /* shrink really */

void
top(heap h)
  ALIAS:
    Heap::Simple::XS::first = 1
  PPCODE:
    if (h->used < 2) {
        if (ix != 1) croak("Empty heap");
        XSRETURN_EMPTY;
    }
    if (h->has_values) PUSHs(sv_2mortal(SvREFCNT_inc(h->values[1])));
    else if (h->order == LESS) XSRETURN_NV( FKEY(NV, h, 1));
    else if (h->order == MORE) XSRETURN_NV(-FKEY(NV, h, 1));
    else croak("No fast %s order", order_name(h));

void
top_key(heap h)
  ALIAS:
    Heap::Simple::XS::min_key   = 1
    Heap::Simple::XS::first_key = 2
  PPCODE:
    if (h->used < 2) {
        if (ix == 2) XSRETURN_EMPTY;
        if (!h->infinity || !SvOK(h->infinity)) croak("Empty heap");
        PUSHs(sv_2mortal(SvREFCNT_inc(h->infinity)));
    } else if (h->fast) {
        if      (h->order== LESS) XSRETURN_NV( FKEY(NV, h, 1));
        else if (h->order== MORE) XSRETURN_NV(-FKEY(NV, h, 1));
        else croak("No fast %s order", order_name(h));
    } else PUSHs(sv_2mortal(SvREFCNT_inc(KEY(h, 1))));

void
keys(heap h)
  PREINIT:
    /* you can actally modify the values through the return */
    size_t i;
    SV *key;
  PPCODE:
    /* Extends one too much. Who cares... */
    EXTEND(SP, h->used);
    EXTEND_MORTAL(h->used);
    if (h->fast) {
        if      (h->order == LESS) for (i=1; i<h->used; i++)
            PUSHs(sv_2mortal(newSVnv( FKEY(NV, h, i))));
        else if (h->order == MORE) for (i=1; i<h->used; i++)
            PUSHs(sv_2mortal(newSVnv(-FKEY(NV, h, i))));
        else croak("No fast %s order", order_name(h));
    } else {
        for (i=1; i<h->used; i++) {
            PUTBACK;
            key = KEY(h, i);
            SPAGAIN;
            PUSHs(sv_2mortal(SvREFCNT_inc(key)));
        }
    }

void
values(heap h)
  PREINIT:
    /* you can actally modify the values through the return */
    size_t i;
  PPCODE:
    /* Extends one too much. Who cares... */
    EXTEND(SP, h->used);
    EXTEND_MORTAL(h->used);
    if (h->has_values) for (i=1; i<h->used; i++)
        PUSHs(sv_2mortal(SvREFCNT_inc(h->values[i])));
    else if (h->order == LESS) for (i=1; i<h->used; i++)
        PUSHs(sv_2mortal(newSVnv( FKEY(NV, h, i))));
    else if (h->order == MORE) for (i=1; i<h->used; i++)
        PUSHs(sv_2mortal(newSVnv(-FKEY(NV, h, i))));
    else croak("No fast %s order", order_name(h));

void
clear(heap h)
  PREINIT:
    SV *key, *value;
  PPCODE:
    if (h->locked) croak("recursive heap change");
    SAVEINT(h->locked);
    h->locked = 1;
    if (h->fast || !h->wrapped) {
        if (h->has_values)
            while (h->used > 1) SvREFCNT_dec(h->values[--h->used]);
        else h->used = 1;
    } else {
        while (h->used > 1) {
            --h->used;
            value = h->values[h->used];
            key   = h->keys  [h->used];
            SvREFCNT_dec(key);
            SvREFCNT_dec(value);
        }
    }
    if ((h->used+4)*4 < h->allocated) extend(h, 0); /* shrink really */

SV *
key(heap h, SV *value)
  CODE:
    if (h->fast) {
        RETVAL = newSVnv(SvNV(fetch_key(aTHX_ h, value)));
    } else {
        RETVAL = SvREFCNT_inc(fetch_key(aTHX_ h, value));
    }

  OUTPUT:
    RETVAL

void
_absorb(SV * heap1, SV *heap2)
  PREINIT:
    int copied2, one_by_one;
    SV *heap1_ref, *value;
    heap h1, h2;
  PPCODE:
    /* Helper for absorb, puts h1 into h2 */
    h1 = C_HEAP(heap1, "heap1");
    /* Keep argument alive for the duration */
    heap1_ref = SvRV(heap1);
    sv_2mortal(SvREFCNT_inc(heap1_ref));
    if (h1->locked) croak("recursive heap change");
    SAVEINT(h1->locked);
    h1->locked = 1;

    if (h1->used < 2) XSRETURN_EMPTY;

    if (MAGIC && SvMAGICAL(heap2)) {
        heap2 = MORTALCOPY(heap2);
        copied2 = 1;
    } else copied2 = 0;
    /* If we are an XS heap, the argument (h2) probably is too */
    h2 = TRY_C_HEAP(heap2);
    if (h2) {
        size_t more, first;

        if (h1 == h2) croak("Self absorption");
        PUTBACK;

        /* Keep argument alive for the duration */
        /* heap2 is now the object, not the object pointer */
        if (!copied2) sv_2mortal(SvREFCNT_inc(heap2));
        more = h1->used-1;
        if (h2->used-1+more > h2->max_count)
            more = h2->max_count-(h2->used-1);
        if (more <= 1) one_by_one = 1;
        else one_by_one = h2->can_die;
        if (!one_by_one) {
            SV *key;
            size_t top, bottom;

            if (h2->locked) croak("recursive heap change");
            SAVEINT(h2->locked);
            h2->locked = 1;

            first = h2->used;
            if (first+more > h2->allocated) extend(h2, more);

            if (h2->fast) {
                NV k;

                while (more--) {
                    if (h1->has_values) value = h1->values[h1->used-1];
                    else if (h1->order == LESS)
                        value = newSVnv(FKEY(NV, h1, h1->used-1));
                    else if (h1->order == MORE)
                        value = newSVnv(-FKEY(NV, h1, h1->used-1));
                    else croak("No fast %s order", order_name(h1));
                    if (h2->has_values) h2->values[h2->used] = value;
                    else sv_2mortal(value);
                    h2->used++;
                    h1->used--;
                    if (h1->wrapped && !h1->fast)
                        SvREFCNT_dec(h1->keys[h1->used]);

                    key = fetch_key(aTHX_ h2, value);
                    /* SvNV will handle get magic (though sv_2nv) */
                    if      (h2->order == LESS) k =  SvNV(key);
                    else if (h2->order == MORE) k = -SvNV(key);
                    else croak("No fast %s order", order_name(h2));
                    FKEY(NV, h2, h2->used-1) = k;
                }
            } else {
                while (more--) {
                    if (h1->has_values) value = h1->values[h1->used-1];
                    else if (h1->order == LESS)
                        value = newSVnv(FKEY(NV, h1, h1->used-1));
                    else if (h1->order == MORE)
                        value = newSVnv(-FKEY(NV, h1, h1->used-1));
                    else croak("No fast %s order", order_name(h1));

                    if (h2->wrapped) {
                        if (h1->has_values) {
                            key = fetch_key(aTHX_ h2, value);
                            h2->keys[h2->used] = newSVsv(key);
                        } else {
                            sv_2mortal(value);
                            key = fetch_key(aTHX_ h2, value);
                            h2->keys[h2->used] = newSVsv(key);
                            SvREFCNT_inc(value);
                        }
                    }
                    h2->values[h2->used] = value;
                    h2->used++;
                    h1->used--;
                    if (h1->wrapped && !h1->fast)
                        SvREFCNT_dec(h1->keys[h1->used]);
                }
            }
            /* Reverse so that low elements are more likely to be on top
               Only makes sense if the orders are likely to be the same.
               It also depends on how a key is gets derived from a value,
               so we just use the order attribute as heuristic
            */
            if (h1->order == h2->order) reverse(h2, first, h2->used-1);

            h2->locked = 0;
            multi_insert(aTHX_ h2, first);
        }
        if (h1->used >= 2 && h1->fast) value = sv_newmortal();
        while (h1->used >= 2) {
            SAVETMPS;
            if (h1->has_values) value = h1->values[h1->used-1];
            else if (h1->order == LESS)
                sv_setnv(value, FKEY(NV, h1, h1->used-1));
            else if (h1->order == MORE)
                sv_setnv(value, -FKEY(NV, h1, h1->used-1));
            else croak("No fast %s order", order_name(h1));

            key_insert(aTHX_ h2, NULL, value);

            h1->used--;
            if (h1->has_values) SvREFCNT_dec(value);
            if (h1->wrapped && !h1->fast) SvREFCNT_dec(h1->keys[h1->used]);
            if ((h1->used+4)*4 < h1->allocated) extend(h1, 0); /* shrink really */
            FREETMPS;
        }
    } else if (!SvOK(heap2)) croak("heap2 is undefined");
    else if (!sv_isobject(heap2)) croak("heap2 is not an object reference");
    else {
        I32 count;

        /* Simple way to keep the refcount up at both levels */
        if (!copied2) heap2 = MORTALCOPY(heap2);
        if (h1->used <= 2) one_by_one = 1;
        else {
            PUSHMARK(SP);
            PUSHs(heap2);
            PUTBACK;
            count = call_method("can_die", G_SCALAR);
            if (count != 1) croak("Forced scalar context call succeeded in returning %d values. This is impossible", (int) count);
            SPAGAIN;
            value = POPs;
            one_by_one = SvTRUE(value);
        }
        if (one_by_one) {
            ENTER;
            if (h1->fast) value = sv_newmortal();
            while (h1->used >= 2) {
                SAVETMPS;
                if (h1->has_values) value = h1->values[h1->used-1];
                else if (h1->order == LESS)
                    sv_setnv(value,  FKEY(NV, h1, h1->used-1));
                else if (h1->order == MORE)
                    sv_setnv(value, -FKEY(NV, h1, h1->used-1));
                else croak("No fast %s order", order_name(h1));
                PUSHMARK(SP);
                PUSHs(heap2);
                PUSHs(value);
                PUTBACK;

                count = call_method("insert", G_VOID);

                SPAGAIN;
                if (count) {
                    if (count < 0) croak("Forced void context call 'insert' succeeded in returning %d values. This is impossible", (int) count);
                    SP -= count;
                }
                h1->used--;
                if (h1->has_values) SvREFCNT_dec(value);
                if (h1->wrapped && !h1->fast) SvREFCNT_dec(h1->keys[h1->used]);
                if ((h1->used+4)*4 < h1->allocated) extend(h1, 0); /* shrink really */
                FREETMPS;
            }
            LEAVE;
        } else {
            size_t i;

            EXTEND(SP, h1->used);
            if (!h1->has_values) EXTEND_MORTAL(h1->used);

            PUSHMARK(SP);
            PUSHs(heap2);
            for (i=1; i<h1->used; i++) {
                if (h1->has_values) value = h1->values[i];
                else {
                    if (h1->order == LESS)
                        value = newSVnv(FKEY(NV, h1, i));
                    else if (h1->order == MORE)
                        value = newSVnv(-FKEY(NV, h1, i));
                    else croak("No fast %s order", order_name(h1));
                    sv_2mortal(value);
                }
                PUSHs(value);
            }
            PUTBACK;
            count = call_method("insert", G_VOID);
            SPAGAIN;
            if (count) {
                if (count < 0) croak("Forced void context call 'insert' succeeded in returning %d values. This is impossible", (int) count);
                SP -= count;
            }
            while (h1->used > 1) {
                h1->used--;
                if (h1->has_values) SvREFCNT_dec(h1->values[h1->used]);
                if (h1->wrapped && !h1->fast) SvREFCNT_dec(h1->keys[h1->used]);
            }
            if ((h1->used+4)*4 < h1->allocated) extend(h1, 0); /* shrink really */
        }
    }

void
_key_absorb(SV * heap1, SV *heap2)
  PREINIT:
    int copied2;
    SV *heap1_ref, *key, *value;
    heap h1, h2;
    int one_by_one;
  PPCODE:
    /* Helper for absorb, puts h1 into h2 */
    h1 = C_HEAP(heap1, "heap1");
    /* Keep arguments alive for the duration */
    heap1_ref = SvRV(heap1);
    sv_2mortal(SvREFCNT_inc(heap1_ref));
    if (h1->locked) croak("recursive heap change");
    SAVEINT(h1->locked);
    h1->locked = 1;

    if (h1->used < 2) XSRETURN_EMPTY;

    if (MAGIC && SvMAGICAL(heap2)) {
        heap2 = MORTALCOPY(heap2);
        copied2 = 1;
    } else copied2 = 0;
    /* If we are an XS heap, the argument probably is too */
    h2 = TRY_C_HEAP(heap2);
    if (h2) {
        size_t more, first;

        if (h1 == h2) croak("Self absorption");
        if (!h2->key_ops) croak("This heap type does not support key_insert");
        PUTBACK;

        /* Keep arguments alive for the duration */
        /* heap2 is now the object, not the object pointer */
        if (!copied2) sv_2mortal(SvREFCNT_inc(heap2));
        more = h1->used-1;
        if (h2->used-1+more > h2->max_count)
            more = h2->max_count-(h2->used-1);
        if (more <= 1) one_by_one = 1;
        else one_by_one = h2->can_die;
        if (!one_by_one) {
            SV *key;

            if (h2->locked) croak("recursive heap change");
            SAVEINT(h2->locked);
            h2->locked = 1;

            first = h2->used;
            if (first+more > h2->allocated) extend(h2, more);

            if (h2->fast) {
                NV k;

                while (more--) {
                    if (!h1->fast) k = SvNV(KEY(h1, h1->used-1));
                    else if (h1->order== LESS)
                        k = FKEY(NV, h1, h1->used-1);
                    else if (h1->order== MORE)
                        k = -FKEY(NV, h1, h1->used-1);
                    else croak("No fast %s order", order_name(h1));

                    if      (h2->order == LESS) FKEY(NV, h2, h2->used-1) =  k;
                    else if (h2->order == MORE) FKEY(NV, h2, h2->used-1) = -k;
                    else croak("No fast %s order", order_name(h2));

                    if (h2->has_values) {
                        if (h1->has_values) value = h1->values[h1->used-1];
                        else if (h1->order == LESS)
                            value = newSVnv(FKEY(NV, h1, h1->used-1));
                        else if (h1->order == MORE)
                            value = newSVnv(-FKEY(NV, h1, h1->used-1));
                        else croak("No fast %s order", order_name(h1));
                        h2->values[h2->used] = value;
                    } else if (h1->has_values)
                        SvREFCNT_dec(h1->values[h1->used-1]);

                    h2->used++;
                    h1->used--;

                    if (h1->wrapped && !h1->fast) SvREFCNT_dec(h1->keys[h1->used]);
                    if ((h1->used+4)*4 < h1->allocated) extend(h1, 0); /* shrink really */
                }
            } else {
                while (more--) {
                    if (h1->has_values)
                        value = h1->values[h1->used-1];
                    else if (h1->order == LESS)
                        value = newSVnv(FKEY(NV, h1, h1->used-1));
                    else if (h1->order == MORE)
                        value = newSVnv(-FKEY(NV, h1, h1->used-1));
                    else croak("No fast %s order", order_name(h1));

                    if (!h1->fast) {
                        key = KEY(h1, h1->used-1);
                        if (!h1->wrapped) SvREFCNT_inc(key);
                    } else if (h1->order== LESS)
                        key = newSVnv(FKEY(NV, h1, h1->used-1));
                    else if (h1->order== MORE)
                        key = newSVnv(-FKEY(NV, h1, h1->used-1));
                    else croak("No fast %s order", order_name(h1));

                    h2->keys  [h2->used] = key;
                    h2->values[h2->used] = value;
                    h2->used++;
                    h1->used--;
                }
            }

            /* Reverse so that low elements are more likely to be on top
               Only makes sense if the orders are likely to be the same.
               It also depends on how a key is gets derived from a value,
               so we just use the order attribute as heuristic
            */
            if (h1->order == h2->order) reverse(h2, first, h2->used-1);

            h2->locked = 0;
            multi_insert(aTHX_ h2, first);
        }

        if (h1->used >= 2) {
            if (h1->fast)        key   = sv_newmortal();
            if (!h1->has_values) value = sv_newmortal();
        }
        while (h1->used >= 2) {
            SAVETMPS;
            if (h1->has_values) value = h1->values[h1->used-1];
            else if (h1->order == LESS)
                sv_setnv(value, FKEY(NV, h1, h1->used-1));
            else if (h1->order == MORE)
                sv_setnv(value, -FKEY(NV, h1, h1->used-1));
            else croak("No fast %s order", order_name(h1));

            if (!h1->fast) key = KEY(h1, h1->used-1);
            else if (h1->order== LESS)
                sv_setnv(key,  FKEY(NV, h1, h1->used-1));
            else if (h1->order== MORE)
                sv_setnv(key, -FKEY(NV, h1, h1->used-1));
            else croak("No fast %s order", order_name(h1));

            key_insert(aTHX_ h2, key, value);

            h1->used--;
            if (h1->has_values) SvREFCNT_dec(value);
            if (h1->wrapped && !h1->fast) SvREFCNT_dec(h1->keys[h1->used]);
            if ((h1->used+4)*4 < h1->allocated) extend(h1, 0); /* shrink really */
            FREETMPS;
        }
    } else if (!SvOK(heap2)) croak("heap2 is undefined");
    else if (!sv_isobject(heap2)) croak("heap2 is not an object reference");
    else {
        I32 count;

        /* Simple way to keep the refcount up at both levels */
        if (!copied2) heap2 = MORTALCOPY(heap2);
        if (h1->used <= 2) one_by_one = 1;
        else {
            PUSHMARK(SP);
            PUSHs(heap2);
            PUTBACK;
            count = call_method("can_die", G_SCALAR);
            if (count != 1) croak("Forced scalar context call succeeded in returning %d values. This is impossible", (int) count);
            SPAGAIN;
            value = POPs;
            one_by_one = SvTRUE(value);
        }
        if (one_by_one) {
            ENTER;
            /* We will push up to three arguments */
            EXTEND(SP, 3);

            if (h1->fast)        key   = sv_newmortal();
            if (!h1->has_values) value = sv_newmortal();
            while (h1->used >= 2) {
                SAVETMPS;
                if (h1->has_values) value = h1->values[h1->used-1];
                else if (h1->order == LESS)
                    sv_setnv(value,  FKEY(NV, h1, h1->used-1));
                else if (h1->order == MORE)
                    sv_setnv(value, -FKEY(NV, h1, h1->used-1));
                else croak("No fast %s order", order_name(h1));

                if (!h1->fast) key = KEY(h1, h1->used-1);
                else if (h1->order== LESS)
                    sv_setnv(key,  FKEY(NV, h1, h1->used-1));
                else if (h1->order== MORE)
                    sv_setnv(key, -FKEY(NV, h1, h1->used-1));
                else croak("No fast %s order", order_name(h1));

                PUSHMARK(SP);
                PUSHs(heap2);
                PUSHs(key);
                PUSHs(value);
                PUTBACK;

                count = call_method("key_insert", G_VOID);

                SPAGAIN;
                if (count) {
                    if (count < 0) croak("Forced void context call 'key_insert' succeeded in returning %d values. This is impossible", (int) count);
                    SP -= count;
                }
                h1->used--;
                if (h1->has_values) SvREFCNT_dec(value);
                if (h1->wrapped && !h1->fast) SvREFCNT_dec(h1->keys[h1->used]);
                if ((h1->used+4)*4 < h1->allocated) extend(h1, 0); /* shrink really */
                FREETMPS;
            }
            LEAVE;
        } else {
            size_t i;

            EXTEND(SP, 2*h1->used-1);
            i = 0;
            if (h1->fast || !h1->wrapped) i += h1->used-1;
            if (h1->has_values) i+= h1->used-1;
            if (i) EXTEND_MORTAL(i);

            /* Drain h1 only *after* calling key_insert in case h2 doesn't
               actually support key_insert */
            PUSHMARK(SP);
            PUSHs(heap2);
            for (i=1; i<h1->used; i++) {
                if (!h1->fast) key = KEY(h1, i);
                else {
                    if (h1->order== LESS) key = newSVnv( FKEY(NV, h1, i));
                    else if (h1->order== MORE) key = newSVnv(-FKEY(NV, h1, i));
                    else croak("No fast %s order", order_name(h1));
                    sv_2mortal(key);
                }
                PUSHs(key);

                if (h1->has_values) value = h1->values[i];
                else {
                    if (h1->order == LESS)
                        value = newSVnv(FKEY(NV, h1, i));
                    else if (h1->order == MORE)
                        value = newSVnv(-FKEY(NV, h1, i));
                    else croak("No fast %s order", order_name(h1));
                    sv_2mortal(value);
                }
                PUSHs(value);
            }
            PUTBACK;
            count = call_method("key_insert", G_VOID);
            SPAGAIN;
            if (count) {
                if (count < 0) croak("Forced void context call 'key_insert' succeeded in returning %d values. This is impossible", (int) count);
                SP -= count;
            }
            while (h1->used > 1) {
                if (h1->has_values) SvREFCNT_dec(h1->values[h1->used]);
                if (h1->wrapped && !h1->fast) SvREFCNT_dec(KEY(h1, h1->used));
                h1->used-1;
            }
            if ((h1->used+4)*4 < h1->allocated) extend(h1, 0); /* shrink really */
        }
    }

void
absorb(SV *heap, ...)
  PREINIT:
    I32 count, i;
    SV *heap2;
  CODE:
    for (i=1; i<items; i++) {
        heap2 = ST(i);
        if (MAGIC && SvMAGICAL(heap2)) heap2 = MORTALCOPY(heap2);
        PUSHMARK(SP);
        XPUSHs(heap2);
        XPUSHs(heap);
        PUTBACK;
        count = call_method("_absorb", G_VOID);
        /* Needed or the stack will remember and return the stuff we pushed */
        SPAGAIN;
        if (count) {
            if (count < 0) croak("Forced void context call '_absorb' succeeded in returning %d values. This is impossible", (int) count);
            SP -= count;
        }
    }

void
key_absorb(SV *heap, ...)
  PREINIT:
    I32 count, i;
    SV *heap2;
  CODE:
    for (i=1; i<items; i++) {
        heap2 = ST(i);
        if (MAGIC && SvMAGICAL(heap2)) heap2 = MORTALCOPY(heap2);
        PUSHMARK(SP);
        XPUSHs(heap2);
        XPUSHs(heap);
        PUTBACK;
        count = call_method("_key_absorb", G_VOID);
        /* Needed or the stack will remember and return the stuff we pushed */
        SPAGAIN;
        if (count) {
            if (count < 0) croak("Forced void context call '_key_absorb' succeeded in returning %d values. This is impossible", (int) count);
            SP -= count;
        }
    }

void
infinity(heap h, SV *new_infinity=0)
  PPCODE:
    if (GIMME_V != G_VOID)
        XPUSHs(h->infinity ?
               sv_2mortal(SvREFCNT_inc(h->infinity)) : &PL_sv_undef);
    if (new_infinity) {
        if (h->infinity) sv_2mortal(h->infinity);
        h->infinity = newSVsv(new_infinity);
    }

IV
key_index(heap h)
  CODE:
    if (h->elements != ARRAY) croak("Heap elements are not of type 'Array'");
    RETVAL = h->aindex;
  OUTPUT:
    RETVAL

SV *
key_name(heap h)
  CODE:
    if (h->elements != HASH) croak("Heap elements are not of type 'Hash'");
    /* Make a copy instead of returning an lvalue
       so that the cached aindex remains valid */
    RETVAL = newSVsv(h->hkey);
  OUTPUT:
    RETVAL

SV *
key_method(heap h)
  CODE:
    if (h->elements != METHOD && h->elements != OBJECT)
        croak("Heap elements are not of type 'Method' or 'Object'");
    RETVAL = SvREFCNT_inc(h->hkey);
  OUTPUT:
    RETVAL

SV *
key_function(heap h)
  CODE:
    if (h->elements != FUNCTION && h->elements != ANY_ELEM)
        croak("Heap elements are not of type 'Function' or 'Any'");
    RETVAL = SvREFCNT_inc(h->hkey);
  OUTPUT:
    RETVAL

void
user_data(heap h, SV *new_user_data=0)
  PPCODE:
    if (GIMME_V != G_VOID)
        PUSHs(h->user_data ? h->user_data : &PL_sv_undef);
    if (new_user_data) {
        if (h->user_data) sv_2mortal(h->user_data);
        h->user_data = newSVsv(new_user_data);
    }

void
order(heap h)
  PPCODE:
    PUSHs(h->order == CODE_ORDER ?
          h->order_sv : sv_2mortal(newSVpv(order_name(h), 0)));

void
elements(heap h)
  PPCODE:
    XPUSHs(sv_2mortal(newSVpv(elements_name(h), 0)));
    if (GIMME_V == G_ARRAY) switch(h->elements) {
      case SCALAR:
        break;
      case ARRAY:
        XPUSHs(sv_2mortal(newSViv(h->aindex)));
        break;
      case HASH:
      case METHOD:
      case OBJECT:
      case FUNCTION:
      case ANY_ELEM:
        if (h->hkey) XPUSHs(sv_2mortal(newSVsv(h->hkey)));
        break;
      default:
        croak("Assertion: unhandled element type %s", elements_name(h));
    }

void
wrapped(heap h)
  PPCODE:
    if (h->key_ops) XSRETURN_YES;
    if (GIMME_V == G_SCALAR) XSRETURN_NO;
    XSRETURN_EMPTY;

void
dirty(heap h)
  PPCODE:
    if (h->dirty) XSRETURN_YES;
    if (GIMME_V == G_SCALAR) XSRETURN_NO;
    XSRETURN_EMPTY;

void
can_die(heap h)
  PPCODE:
    /* ->fast types are wrapped too really */
    if (h->can_die) XSRETURN_YES;
    if (GIMME_V == G_SCALAR) XSRETURN_NO;
    XSRETURN_EMPTY;

void
max_count(heap h)
  PPCODE:
    if (h->max_count == MAX_SIZE) XSRETURN_NV(INFINITY);
    XSRETURN_UV(h->max_count);

void
merge_arrays(heap h, ...)
  PREINIT:
    I32 i, j;
    size_t l, filled, left, k0, k1, k2;
    SV *value, **ptr, *key;
    AV *av, *work_av;
    merge *work_heap, here;
    fast_merge *fast_work_heap, fast_here;
  CODE:
    filled = left = 0;
    for (i=1; i<items; i++) {
        value = ST(i);
        if (MAGIC) SvGETMAGIC(value);
        if (!SvROK(value))
            croak("argument %u is not a reference", (unsigned int) i-1);

        work_av = (AV*) SvRV(value);
        if (MAGIC) SvGETMAGIC((SV *) work_av);
        if (SvTYPE(work_av) != SVt_PVAV)
            croak("argument %u is not an array reference", (unsigned int) i-1);
        j = av_len(work_av);
        if (j < 0) continue;
        filled++;
        left += j+1;
        av = work_av;
    }

    work_av = newAV();
    value = newRV_noinc((SV *) work_av);
    ST(0) = sv_2mortal(value);
    k2 = left;
    if (h->max_count != MAX_SIZE && h->max_count < left)
	left = h->max_count;
    av_extend(work_av, (I32) left - 1);

    switch(filled) {
      case 0: break;
      case 1:
        for (k0= k2-left, k1=0; k1 < left; k0++, k1++) {
            ptr = av_fetch(av, k0, 0);
            if (ptr) {
                value = newSVsv(*ptr);
                if (!av_store(work_av, k1, value)) {
                    SvREFCNT_dec(value);
                    croak("Assertion: Could not store value");
                }
            }
        }
        break;
      default:
        if (h->fast) {
            if (h->max_count < filled) {
                filled = h->max_count;
                New(__LINE__ % 1000, fast_work_heap, filled+1, struct fast_merge);
                SAVEFREEPV(fast_work_heap);
                k1 = 0;
                for (i=1; i<items && k1 < filled; i++) {
                    value = ST(i);
                    if (!SvROK(value))
                        croak("argument %u is not a reference (it was last time)",
                              (unsigned int) i-1);

                    av = (AV*) SvRV(value);
                    if (SvTYPE(work_av) != SVt_PVAV)
                        croak("argument %u is not an array reference (it was last time)", (unsigned int) i-1);
                    j = av_len(av);
                    if (j < 0) continue;
                    ++k1;
                    ptr = av_fetch(av, j, 0);
                    key = fetch_key(aTHX_ h, ptr ? *ptr : &PL_sv_undef);
                    if      (h->order == LESS)
                        fast_work_heap[k1].key =  SvNV(key);
                    else if (h->order == MORE)
                        fast_work_heap[k1].key= -SvNV(key);
                    else croak("No fast %s order", order_name(h));
                    fast_work_heap[k1].array = av;
                    fast_work_heap[k1].index = j;
                }
                if (k1 != filled)
                    croak("Less than %"UVuf" non-empty array references in the second round", (UV) filled);

                /* heapify, top is smallest */
                for (k2 = filled/2; k2 > 0; k2--) {
                    l = k2*2;
                    fast_here = fast_work_heap[k2];
                    while (l < filled) {
                        if (fast_work_heap[l].key < fast_here.key) {
                            if (fast_work_heap[l+1].key < fast_work_heap[l].key) l++;
                        } else if (fast_work_heap[l+1].key < fast_here.key) l++;
                        else break;
                        fast_work_heap[l/2] = fast_work_heap[l];
                        l *= 2;
                    }
                    if (l == filled && fast_work_heap[l].key < fast_here.key) {
                        fast_work_heap[l/2] = fast_work_heap[l];
                        l *= 2;
                    }
                    fast_work_heap[l/2] = fast_here;
                }
                for (; i<items; i++) {
                    value = ST(i);
                    if (!SvROK(value))
                        croak("argument %u is not a reference (it was last time)",
                              (unsigned int) i-1);

                    av = (AV*) SvRV(value);
                    if (SvTYPE(work_av) != SVt_PVAV)
                        croak("argument %u is not an array reference (it was last time)", (unsigned int) i-1);
                    j = av_len(av);
                    if (j < 0) continue;
                    ptr = av_fetch(av, j, 0);
                    key = fetch_key(aTHX_ h, ptr ? *ptr : &PL_sv_undef);
                    if      (h->order == LESS) fast_here.key =  SvNV(key);
                    else if (h->order == MORE) fast_here.key = -SvNV(key);
                    else croak("No fast %s order", order_name(h));
                    if (fast_work_heap[1].key >= fast_here.key) continue;
                    l = 2;
                    while (l < filled) {
                        if (fast_work_heap[l].key < fast_here.key) {
                            if (fast_work_heap[l+1].key < fast_work_heap[l].key) l++;
                        } else if (fast_work_heap[l+1].key < fast_here.key) l++;
                        else break;
                        fast_work_heap[l/2] = fast_work_heap[l];
                        l *= 2;
                    }
                    if (l == filled && fast_work_heap[l].key < fast_here.key)
                        fast_work_heap[l/2] = fast_work_heap[l];
                    else l /= 2;
                    fast_work_heap[l].key = fast_here.key;
                    fast_work_heap[l].array = av;
                    fast_work_heap[l].index = j;
                }
            } else {
                New(__LINE__ % 1000, fast_work_heap, filled+1, struct fast_merge);
                SAVEFREEPV(fast_work_heap);
                k1 = 0;
                for (i=1; i<items; i++) {
                    value = ST(i);
                    if (!SvROK(value))
                        croak("argument %u is not a reference (it was last time)",
                              (unsigned int) i-1);

                    av = (AV*) SvRV(value);
                    if (SvTYPE(work_av) != SVt_PVAV)
                        croak("argument %u is not an array reference (it was last time)", (unsigned int) i-1);
                    j = av_len(av);
                    if (j < 0) continue;
                    if (++k1 > filled)
                        croak("More than %"UVuf" non-empty array references in the second round", (UV) filled);
                    ptr = av_fetch(av, j, 0);
                    key = fetch_key(aTHX_ h, ptr ? *ptr : &PL_sv_undef);
                    if      (h->order == LESS) fast_work_heap[k1].key =  SvNV(key);
                    else if (h->order == MORE) fast_work_heap[k1].key = -SvNV(key);
                    else croak("No fast %s order", order_name(h));
                    fast_work_heap[k1].array = av;
                    fast_work_heap[k1].index = j;
                }
                if (k1 != filled)
                    croak("Less than %"UVuf" non-empty array references in the second round", (UV) filled);
            }

            /* heapify */
            for (k2 = filled/2; k2 > 0; k2--) {
                l = k2*2;
                fast_here = fast_work_heap[k2];
                while (l < filled) {
                    if (fast_here.key < fast_work_heap[l].key) {
                        if (fast_work_heap[l].key < fast_work_heap[l+1].key) l++;
                    } else if (fast_here.key < fast_work_heap[l+1].key) l++;
                    else break;
                    fast_work_heap[l/2] = fast_work_heap[l];
                    l *= 2;
                }
                if (l == filled && fast_here.key < fast_work_heap[l].key) {
                    fast_work_heap[l/2] = fast_work_heap[l];
                    l *= 2;
                }
                fast_work_heap[l/2] = fast_here;
            }

            /* Start extracting */
            while (1) {
                j = fast_work_heap[1].index;
                av = fast_work_heap[1].array;
                ptr = av_fetch(av, j, 0);
                if (ptr) {
                    value = newSVsv(*ptr);
                    --left;
                    if (!av_store(work_av, left, value)) {
                        SvREFCNT_dec(value);
                        croak("Assertion: Could not store value");
                    }
                }
                if (left == 0) break;
                j--;
                if (j >= 0) {
                    ptr = av_fetch(av, j, 0);
                    key = fetch_key(aTHX_ h, ptr ? *ptr : &PL_sv_undef);
                    if      (h->order == LESS) fast_here.key =  SvNV(key);
                    else if (h->order == MORE) fast_here.key = -SvNV(key);
                    else croak("No fast %s order", order_name(h));
                    fast_here.array = av;
                    fast_here.index = j;
                } else {
                    fast_here = fast_work_heap[filled--];
                    if (filled <= 1) {
                        av = fast_here.array;
                        for (j = fast_here.index; j >= 0; j--) {
                            --left;
                            ptr = av_fetch(av, j, 0);
                            if (ptr) {
                                value = newSVsv(*ptr);
                                if (!av_store(work_av, left, value)) {
                                    SvREFCNT_dec(value);
                                    croak("Assertion: Could not store value");
                                }
                            }
                            if (left == 0) break;
                        }
                        if (left) croak("Not enough values the second time round");
                        break;
                    }
                }
                l = 2;
                while (l < filled) {
                    if (fast_here.key < fast_work_heap[l].key) {
                        if (fast_work_heap[l].key < fast_work_heap[l+1].key) l++;
                    } else if (fast_here.key < fast_work_heap[l+1].key) l++;
                    else break;
                    fast_work_heap[l/2] = fast_work_heap[l];
                    l *= 2;
                }
                if (l == filled && fast_here.key < fast_work_heap[l].key) {
                    fast_work_heap[l/2] = fast_work_heap[l];
                    l *= 2;
                }
                fast_work_heap[l/2] = fast_here;
            }
        } else {
            if (h->max_count < filled) {
                filled = h->max_count;
                New(__LINE__ % 1000, work_heap, filled+1, struct merge);
                SAVEFREEPV(work_heap);
                k1 = 0;
                for (i=1; i<items && k1 < filled; i++) {
                    value = ST(i);
                    if (!SvROK(value))
                        croak("argument %u is not a reference (it was last time)",
                              (unsigned int) i-1);

                    av = (AV*) SvRV(value);
                    if (SvTYPE(work_av) != SVt_PVAV)
                        croak("argument %u is not an array reference (it was last time)", (unsigned int) i-1);
                    j = av_len(av);
                    if (j < 0) continue;
                    ++k1;
                    ptr = av_fetch(av, j, 0);
                    work_heap[k1].key = fetch_key(aTHX_ h, ptr ? *ptr : &PL_sv_undef);
                    work_heap[k1].array = av;
                    work_heap[k1].index = j;
                }
                if (k1 != filled)
                    croak("Less than %"UVuf" non-empty array references in the second round", (UV) filled);

                /* heapify, top is smallest */
                for (k2 = filled/2; k2 > 0; k2--) {
                    l = k2*2;
                    here = work_heap[k2];
                    while (l < filled) {
                        if (less(aTHX_ h, work_heap[l].key, here.key)) {
                            if (less(aTHX_ h, work_heap[l+1].key, work_heap[l].key)) l++;
                        } else if (less(aTHX_ h, work_heap[l+1].key, here.key)) l++;
                        else break;
                        work_heap[l/2] = work_heap[l];
                        l *= 2;
                    }
                    if (l == filled && less(aTHX_ h, work_heap[l].key, here.key)) {
                        work_heap[l/2] = work_heap[l];
                        l *= 2;
                    }
                    work_heap[l/2] = here;
                }
                for (; i<items; i++) {
                    value = ST(i);
                    if (!SvROK(value))
                        croak("argument %u is not a reference (it was last time)",
                              (unsigned int) i-1);

                    av = (AV*) SvRV(value);
                    if (SvTYPE(work_av) != SVt_PVAV)
                        croak("argument %u is not an array reference (it was last time)", (unsigned int) i-1);
                    j = av_len(av);
                    if (j < 0) continue;
                    ptr = av_fetch(av, j, 0);
                    here.key   = fetch_key(aTHX_ h, ptr ? *ptr : &PL_sv_undef);
                    if (!less(aTHX_ h, work_heap[1].key, here.key)) continue;
                    l = 2;
                    while (l < filled) {
                        if (less(aTHX_ h, work_heap[l].key, here.key)) {
                            if (less(aTHX_ h, work_heap[l+1].key, work_heap[l].key)) l++;
                        } else if (less(aTHX_ h, work_heap[l+1].key, here.key)) l++;
                        else break;
                        work_heap[l/2] = work_heap[l];
                        l *= 2;
                    }
                    if (l == filled &&
                        less(aTHX_ h, work_heap[l].key, here.key))
                        work_heap[l/2] = work_heap[l];
                    else l /= 2;
                    work_heap[l].key = here.key;
                    work_heap[l].array = av;
                    work_heap[l].index = j;
                }
            } else {
                New(__LINE__ % 1000, work_heap, filled+1, struct merge);
                SAVEFREEPV(work_heap);
                k1 = 0;
                for (i=1; i<items; i++) {
                    value = ST(i);
                    if (!SvROK(value))
                        croak("argument %u is not a reference (it was last time)",
                              (unsigned int) i-1);

                    av = (AV*) SvRV(value);
                    if (SvTYPE(work_av) != SVt_PVAV)
                        croak("argument %u is not an array reference (it was last time)", (unsigned int) i-1);
                    j = av_len(av);
                    if (j < 0) continue;
                    if (++k1 > filled)
                        croak("More than %"UVuf" non-empty array references in the second round", (UV) filled);
                    ptr = av_fetch(av, j, 0);
                    work_heap[k1].key   = fetch_key(aTHX_ h, ptr ? *ptr : &PL_sv_undef);
                    work_heap[k1].array = av;
                    work_heap[k1].index = j;
                }
                if (k1 != filled)
                    croak("Less than %"UVuf" non-empty array references in the second round", (UV) filled);
            }

            /* heapify */
            for (k2 = filled/2; k2 > 0; k2--) {
                l = k2*2;
                here = work_heap[k2];
                while (l < filled) {
                    if (less(aTHX_ h, here.key, work_heap[l].key)) {
                        if (less(aTHX_ h, work_heap[l].key, work_heap[l+1].key)) l++;
                    } else if (less(aTHX_ h, here.key, work_heap[l+1].key)) l++;
                    else break;
                    work_heap[l/2] = work_heap[l];
                    l *= 2;
                }
                if (l == filled && less(aTHX_ h, here.key, work_heap[l].key)) {
                    work_heap[l/2] = work_heap[l];
                    l *= 2;
                }
                work_heap[l/2] = here;
            }

            /* Start extracting */
            while (1) {
                j = work_heap[1].index;
                av = work_heap[1].array;
                ptr = av_fetch(av, j, 0);
                if (ptr) {
                    value = newSVsv(*ptr);
                    --left;
                    if (!av_store(work_av, left, value)) {
                        SvREFCNT_dec(value);
                        croak("Assertion: Could not store value");
                    }
                }
                if (left == 0) break;
                j--;
                if (j >= 0) {
                    ptr = av_fetch(av, j, 0);
                    here.key   = fetch_key(aTHX_ h, ptr ? *ptr : &PL_sv_undef);
                    here.array = av;
                    here.index = j;
                } else {
                    here = work_heap[filled--];
                    if (filled <= 1) {
                        av = here.array;
                        for (j = here.index; j >= 0; j--) {
                            --left;
                            ptr = av_fetch(av, j, 0);
                            if (ptr) {
                                value = newSVsv(*ptr);
                                if (!av_store(work_av, left, value)) {
                                    SvREFCNT_dec(value);
                                    croak("Assertion: Could not store value");
                                }
                            }
                            if (left == 0) break;
                        }
                        if (left) croak("Not enough values the second time round");
                        break;
                    }
                }
                l = 2;
                while (l < filled) {
                    if (less(aTHX_ h, here.key, work_heap[l].key)) {
                        if (less(aTHX_ h, work_heap[l].key, work_heap[l+1].key)) l++;
                    } else if (less(aTHX_ h, here.key, work_heap[l+1].key)) l++;
                    else break;
                    work_heap[l/2] = work_heap[l];
                    l *= 2;
                }
                if (l == filled && less(aTHX_ h, here.key, work_heap[l].key)) {
                    work_heap[l/2] = work_heap[l];
                    l *= 2;
                }
                work_heap[l/2] = here;
            }
        }
        break;
    }
    XSRETURN(1);

void
DESTROY(heap h)
  PREINIT:
    SV *key, *value;
  PPCODE:
    /* Let's assume the module isn't buggy and it always increases the refcount
       on the heap during modification.
       That means that the user is explicitely calling DESTROY */
    if (h->locked)
	croak("Refusing explicit DESTROY call during heap modification");
    h->locked = 1;
    if (h->fast || !h->wrapped) {
        if (h->has_values)
            while (h->used > 1) SvREFCNT_dec(h->values[--h->used]);
    } else {
        while (h->used > 1) {
            --h->used;
            value = h->values[h->used];
            key   = h->keys  [h->used];
            SvREFCNT_dec(key);
            SvREFCNT_dec(value);
        }
    }
    if (h->hkey) {
        key = h->hkey;
        h->hkey = NULL;
        SvREFCNT_dec(key);
    }
    if (h->infinity) {
        key = h->infinity;
        h->infinity = NULL;
        SvREFCNT_dec(key);
    }
    if (h->user_data) {
        key = h->user_data;
        h->user_data = NULL;
        SvREFCNT_dec(key);
    }
    if (h->order_sv) {
        key = h->order_sv;
        h->order_sv = NULL;
        SvREFCNT_dec(key);
    }
    if (h->values) Safefree(h->values);
    if (h->keys)   Safefree(h->keys);
    Safefree(h);

BOOT:
    if (MAX_SIZE < 0) croak("signed size_t");