scriptators/perl/Perltator.cpp

/*
 * Licensed to the Apache Software Foundation (ASF) under one
 * or more contributor license agreements.  See the NOTICE file
 * distributed with this work for additional information
 * regarding copyright ownership.  The ASF licenses this file
 * to you under the Apache License, Version 2.0 (the
 * "License"); you may not use this file except in compliance
 * with the License.  You may obtain a copy of the License at
 *
 *   http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing,
 * software distributed under the License is distributed on an
 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
 * KIND, either express or implied.  See the License for the
 * specific language governing permissions and limitations
 * under the License.
 */

#include "uima/api.hpp"

#include <EXTERN.h>
#include <perl.h>

#define THREAD_PROTECTION
#ifdef THREAD_PROTECTION
#include "ThreadAnnotator.h"
#endif

using namespace uima;
using namespace icu;
using namespace std;

#define MODULENAME "Perltator"

// copied from SwigGenerated code

// this function requires the SWIG code to be compiled with
// SWIGRUNTIME defined to be "", otherwise this function is static
// and does not scope outside of the library
#ifndef SWIG_GLOBAL 
// SWIG 1.3.25 or better
#include "uimaperlwrap.h" 
#else
// Oh so last week, SWIG 1.3.21 style
struct swig_type_info;
struct swig_module_info;
extern "C" SV *SWIG_Perl_NewPointerObj(void *, swig_type_info *, int);
extern "C" swig_type_info * SWIG_Perl_TypeQuery(const char *);
#define SWIG_Perl_NewPointerObj(a,b,c) SWIG_Perl_NewPointerObj(a,b,c)
#define SWIG_TypeQueryModule(a,b,c) SWIG_Perl_TypeQuery(c)
#define SWIG_Perl_GetModule() ((swig_module_info *) 1)
#endif


EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
EXTERN_C void boot_perltator (pTHX_ CV* cv);

EXTERN_C void
xs_init(pTHX)
{
  char *file = __FILE__;
  /* DynaLoader is a special case */
  newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  /* we will always need UIMA */
  newXS("uimac::boot_perltator", boot_perltator, file);
}

class Perltator : public Annotator {
  int debug;
  swig_type_info *cas_type, *rs_type, *ts_type;
  PerlInterpreter *my_perl;

public:
  Perltator() : my_perl(0) {}

  // We construct a perl interpreter in initialize - it lives for the
  // life of the annotator - even if reconfigure happens.  Reconfigure
  // and intialize both set dirty so the source code in the source file
  // and contained in the type system are evaluated.

  TyErrorId initialize(AnnotatorContext &ac) {
    swig_type_info *ac_type;
    char srcfile[1000 + 256];

    if (ac.isParameterDefined("DebugLevel")) {
      ac.extractValue("DebugLevel", debug);
    }
    if (debug > 1) {
      cerr<< MODULENAME ": Initialize - debug=" << debug <<endl;
    }
    if (!ac.isParameterDefined("SourceFile")) {
      cerr<< MODULENAME ": Missing Perl SourceFile" <<endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
    }

    UnicodeString fn;
    ac.extractValue(UnicodeString("SourceFile"), fn);
    if (fn == "") {
      cerr<< MODULENAME ": Empty Perl SourceFile" <<endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
    }

    UErrorCode err = U_ZERO_ERROR;
    fn.extract(srcfile,sizeof(srcfile),0,err);
    if (U_FAILURE(err)) {
      cerr << MODULENAME ": Unable to extract parameter, got " << u_errorName(err) << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
    }

    if (my_perl == 0) {
      my_perl = perl_alloc();
      perl_construct(my_perl);
      
      char * my_argv[] = { "", "-S", srcfile };
      perl_parse(my_perl, xs_init, 3, my_argv, (char **) NULL);
      PL_exit_flags |= PERL_EXIT_DESTRUCT_END;

      perl_run(my_perl);


      // convert cas and rs to python variables (parameters) 
      swig_module_info *module = SWIG_Perl_GetModule(NULL);
      if (!module) {
        cerr << MODULENAME ": could not get Perl swig module" << endl;
        return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
      }

      ts_type = SWIG_TypeQueryModule(module,module, "TypeSystem *");
      if (!ts_type) {
        cerr << MODULENAME ": could lookup TypeSystem type in swig" << endl;
        return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
      }
      ac_type = SWIG_TypeQueryModule(module,module, "AnnotatorContext *");
      if (!ac_type) {
        cerr << MODULENAME ": could lookup AnnotatorContext type in swig" << endl;
        return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
      }
      cas_type = SWIG_TypeQueryModule(module,module, "CAS *");
      if (!cas_type) {
        cerr << MODULENAME ": could lookup cas type in swig" << endl;
        return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
      }
      rs_type = SWIG_TypeQueryModule(module,module, 
	"ResultSpecification *");
      if (!rs_type) {
        cerr << MODULENAME ": could lookup rs type in swig" << endl;
        return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
      }
    }

    dSP ;

    ENTER ;
    SAVETMPS ;

    PUSHMARK(SP) ;
    XPUSHs(SWIG_Perl_NewPointerObj(
       reinterpret_cast<void *>( const_cast<AnnotatorContext *>(&ac)),
       ac_type, 0));

    PUTBACK ;
    call_pv("initialize", G_DISCARD);

    FREETMPS ;
    LEAVE ;

    if (SvTRUE(ERRSV)) {
      cerr << MODULENAME  " initialize error " 
           << SvPV_nolen(ERRSV) << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
    }

    return UIMA_ERR_NONE;
  }

  TyErrorId reconfigure() {
    if (my_perl == 0) {
      cerr << MODULENAME ": not initialized in reconfigure" << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
    }
    if (debug > 1) {
      cerr<< MODULENAME ": reconfigure" <<endl;
    }

    dSP ;
    ENTER ;
    SAVETMPS ;

    PUSHMARK(SP) ;
    PUTBACK ;
    call_pv("reconfigure", G_DISCARD);

    FREETMPS ;
    LEAVE ;

    if (SvTRUE(ERRSV)) {
      cerr << MODULENAME " reconfigure error " 
           << SvPV_nolen(ERRSV) << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
    }

    return UIMA_ERR_NONE;
  }
  
  TyErrorId batchProcessComplete() {
    if (my_perl == 0) {
      cerr << MODULENAME 
           ": not initialized in batchProcessComplete" << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_PROCESS;
    }
    if (debug > 1) {
      cerr<< MODULENAME ": batchProcessComplete" <<endl;
    }

    dSP ;
    ENTER ;
    SAVETMPS ;

    PUSHMARK(SP) ;
    PUTBACK ;
    call_pv("batchProcessComplete", G_DISCARD);

    FREETMPS ;
    LEAVE ;

    if (SvTRUE(ERRSV)) {
      cerr << MODULENAME " batchProcessComplete error "
	   << SvPV_nolen(ERRSV) << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_PROCESS;
    }

    return UIMA_ERR_NONE;
  }

  TyErrorId collectionProcessComplete() {
    if (my_perl == 0) {
      cerr << MODULENAME 
           ": not initialized in collectionProcessComplete" << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_PROCESS;
    }
    if (debug > 1) {
      cerr<< MODULENAME ": collectionProcessComplete" <<endl;
    }

    dSP ;
    ENTER ;
    SAVETMPS ;

    PUSHMARK(SP) ;
    PUTBACK ;
    call_pv("collectionProcessComplete", G_DISCARD);

    FREETMPS ;
    LEAVE ;

    if (SvTRUE(ERRSV)) {
      cerr << MODULENAME " collectionProcessComplete error "
	   << SvPV_nolen(ERRSV) << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_PROCESS;
    }

    return UIMA_ERR_NONE;
  }

  TyErrorId typeSystemInit(TypeSystem const &ts) {
    if (my_perl == 0) {
      cerr << MODULENAME ": not initialized in typeSystemInit" << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
    }
    if (debug > 1) {
      cerr<< MODULENAME ": typeSystemInit" <<endl;
    }

    dSP ;
    ENTER ;
    SAVETMPS ;

    PUSHMARK(SP) ;
    XPUSHs(SWIG_Perl_NewPointerObj(
       reinterpret_cast<void *>( const_cast<TypeSystem *>(&ts)),
       ts_type, 0));

    PUTBACK ;
    call_pv("typeSystemInit", G_DISCARD);

    FREETMPS ;
    LEAVE ;

    if (SvTRUE(ERRSV)) {
      cerr << MODULENAME  " typeSystemInit error " << SvPV_nolen(ERRSV)
           << endl;
      return UIMA_ERR_USER_ANNOTATOR_COULD_NOT_INIT;
    }

    return UIMA_ERR_NONE;
  }

/** 
 * call the UIMA Annotator to deinitialize itself based on a UIMA engine
 * and return a UIMA error code
 */
  TyErrorId destroy()
  { 
    if (debug > 1) {
      cerr<< MODULENAME ": destroy " << endl;
    }

    dSP ;
    ENTER ;
    SAVETMPS ;

    PUSHMARK(SP) ;
    PUTBACK ;
    call_pv("destroy", G_DISCARD);

    FREETMPS ;
    LEAVE ;

    if (SvTRUE(ERRSV)) {
      cerr << MODULENAME  " destory error (ignored) " 
           << SvPV_nolen(ERRSV) << endl;
    }

    PL_perl_destruct_level = 0;
    perl_destruct(my_perl);
    perl_free(my_perl);
    my_perl = 0;
    return (TyErrorId)UIMA_ERR_NONE;
  }

/**
 * call the UIMA Annotator to perform its duty based on a UIMA engine
 * and return a UIMA error code
 */
  TyErrorId process(CAS &_cas, ResultSpecification const & _rs) { 
    if (debug > 1) {
      cerr<< MODULENAME ": process " << endl;
    }

    TyErrorId rc = UIMA_ERR_NONE;
 
    dSP ;
    ENTER ;
    SAVETMPS ;

    PUSHMARK(SP) ;
    XPUSHs(
       SWIG_Perl_NewPointerObj(
       reinterpret_cast<void *>( &_cas), cas_type, 0));
    XPUSHs(
       SWIG_Perl_NewPointerObj(
       reinterpret_cast<void *>( 
		const_cast<ResultSpecification *>(&_rs)),
       rs_type, 0));

    PUTBACK ;
    call_pv("process", G_DISCARD);

    FREETMPS ;
    LEAVE ;

    if (SvTRUE(ERRSV)) {
      cerr << MODULENAME " process error " 
	   << SvPV_nolen(ERRSV) << endl;
      rc = UIMA_ERR_USER_ANNOTATOR_COULD_NOT_PROCESS;
    }

    return rc;
  }

};


#ifdef THREAD_PROTECTION
MAKE_AE(ThreadAnnotator<Perltator>);
#else
MAKE_AE(Perltator);
#endif


/* <EOF> */