path: root/umbrello/umbrello/codegenerators/perlwriter.cpp

/***************************************************************************
    begin                : Wed Jan 22 2003
    copyright            : (C) 2003 by David Hugh-Jones
      (C) 2004-2006  Umbrello UML Modeller Authors <uml-devel@uml.sf.net>
    email                : hughjonesd@yahoo.co.uk
 ***************************************************************************/

/***************************************************************************
 *                                                                         *
 *   This program is free software; you can redistribute it and/or modify  *
 *   it under the terms of the GNU General Public License as published by  *
 *   the Free Software Foundation; either version 2 of the License, or     *
 *   (at your option) any later version.                                   *
 *                                                                         *
 ***************************************************************************/

#include "perlwriter.h"
#include "../classifier.h"
#include "../operation.h"
#include "../umldoc.h"
#include "../association.h"
#include "../attribute.h"
#include "../uml.h"

#include <kdebug.h>
#include <tqregexp.h>
#include <tqstring.h>
#include <tqdir.h>
#include <tqdatetime.h>
#include <tqtextstream.h>

PerlWriter::PerlWriter()
{
}

PerlWriter::~PerlWriter() {}

bool PerlWriter::GetUseStatements(UMLClassifier *c, TQString &Ret,
                                  TQString &ThisPkgName){

  if(!c){
    return(false);
  }

  UMLPackageList includes;
  findObjectsRelated(c,includes);
  UMLPackage *conc;
  TQString AV = "@";
  TQString SV = "$";
  TQString HV = "%";
  for(conc = includes.first(); conc ;conc = includes.next()) {
    if (conc->getBaseType() == Uml::ot_Datatype)
        continue;
    TQString neatName = cleanName(conc->getName());
    if (neatName != AV && neatName != SV && neatName != HV) {
      TQString OtherPkgName =  conc->getPackage(".");
      OtherPkgName.replace(TQRegExp("\\."),"::");
      TQString OtherName = OtherPkgName + "::" + cleanName(conc->getName());

      // Only print out the use statement if the other package isn't the
      // same as the one we are working on. (This happens for the
      // "Singleton" design pattern.)
      if(OtherName != ThisPkgName){
        Ret += "use ";
        Ret += OtherName;
        Ret +=  ';';
        Ret += m_endl;
      }
    }
  }
  UMLClassifierList  superclasses = c->getSuperClasses();
  if (superclasses.count()) {
    Ret += m_endl;
    Ret += "use base qw( ";
    for (UMLClassifier *obj = superclasses.first();
         obj; obj = superclasses.next()) {
      TQString packageName =  obj->getPackage(".");
      packageName.replace(TQRegExp("\\."),"::");

      Ret += packageName + "::" + cleanName(obj->getName()) + ' ';
    }
    Ret += ");" + m_endl;
  }

  return(true);
}

void PerlWriter::writeClass(UMLClassifier *c) {

  /*  if(!c) {
      kDebug()<<"Cannot write class of NULL concept!" << endl;
      return;
      }
  */
  TQString classname = cleanName(c->getName());// this is fine: cleanName is "::-clean"
  TQString packageName =  c->getPackage(".");
  TQString fileName;

  // Replace all white spaces with blanks
  packageName.simplifyWhiteSpace();

  // Replace all blanks with underscore
  packageName.replace(TQRegExp(" "), "_");

  // Replace all dots (".") with double colon scope resolution operators
  // ("::")
  packageName.replace(TQRegExp("\\."),"::");

  // Store complete package name
  TQString ThisPkgName = packageName + "::" + classname;

  fileName = findFileName(c, ".pm");
  // the above lower-cases my nice class names. That is bad.
  // correct solution: refactor,
  // split massive findFileName up, reimplement
  // parts here
  // actual solution: shameful ".pm" hack in codegenerator

  CodeGenerationPolicy *pol = UMLApp::app()->getCommonPolicy();
  TQString curDir = pol->getOutputDirectory().absPath();
  if (fileName.contains("::")) {
    // create new directories for each level
    TQString newDir;
    newDir = curDir;
    TQString fragment = fileName;
    TQDir* existing = new TQDir (curDir);
    TQRegExp regEx("(.*)(::)");
    regEx.setMinimal(true);
    while (regEx.search(fragment) > -1) {
      newDir = regEx.cap(1);
      fragment.remove(0, (regEx.pos(2) + 2)); // get round strange minimal matching bug
      existing->setPath(curDir + '/' + newDir);
      if (! existing->exists()) {
        existing->setPath(curDir);
        if (! existing->mkdir(newDir)) {
          emit codeGenerated(c, false);
          return;
        }
      }
      curDir += '/' + newDir;
    }
    fileName = fragment + ".pm";
  }
  if (fileName.isEmpty()) {
    emit codeGenerated(c, false);
    return;
  }
  TQString oldDir = pol->getOutputDirectory().absPath();
  pol->setOutputDirectory(curDir);
  TQFile fileperl;
  if(!openFile(fileperl, fileName)) {
    emit codeGenerated(c, false);
    return;
  }
  TQTextStream perl(&fileperl);
  pol->setOutputDirectory(oldDir);

  //======================================================================
  // Start generating the code!!
  //======================================================================

  // try to find a heading file (license, comments, etc)
  TQString str;
  bool bPackageDeclared = false;
  bool bUseStmsWritten  = false;

  str = getHeadingFile(".pm");   // what this mean?
  if(!str.isEmpty()) {
    str.replace(TQRegExp("%filename%"),fileName);
    str.replace(TQRegExp("%filepath%"),fileperl.name());
    str.replace(TQRegExp("%year%"),TQDate::tqcurrentDate().toString("yyyy"));
    str.replace(TQRegExp("%date%"),TQDate::tqcurrentDate().toString());
    str.replace(TQRegExp("%time%"),TQTime::currentTime().toString());
    str.replace(TQRegExp("%package-name%"),ThisPkgName);
    if(str.find(TQRegExp("%PACKAGE-DECLARE%"))){
      str.replace(TQRegExp("%PACKAGE-DECLARE%"),
                  "package " + ThisPkgName + ';'
                  + m_endl + m_endl
                  + "#UML_MODELER_BEGIN_PERSONAL_VARS_" + classname
                  + m_endl + m_endl
                  + "#UML_MODELER_END_PERSONAL_VARS_" + classname
                  + m_endl
                  );
      bPackageDeclared = true;
    }

    if(str.find(TQRegExp("%USE-STATEMENTS%"))){
      TQString UseStms;
      if(GetUseStatements(c,UseStms,ThisPkgName)){
        str.replace(TQRegExp("%USE-STATEMENTS%"), UseStms);
        bUseStmsWritten = true;
      }
    }

    perl<<str<<m_endl;
  }

  // if the package wasn't declared above during keyword substitution,
  // add it now. (At the end of the file.)
  if(! bPackageDeclared){
    perl << m_endl << m_endl << "package " <<ThisPkgName << ";" << m_endl
         << m_endl;
    //write includes
    perl << m_endl << "#UML_MODELER_BEGIN_PERSONAL_VARS_" << classname
         << m_endl ;
    perl << m_endl << "#UML_MODELER_END_PERSONAL_VARS_" << classname
         << m_endl << m_endl ;
  }

  if(! bUseStmsWritten){
    TQString UseStms;
    if(GetUseStatements(c,UseStms,ThisPkgName)){
      perl<<UseStms<<m_endl;
    }
  }

  perl << m_endl;

  // Do we really need these for anything???
  UMLAssociationList aggregations = c->getAggregations();
  UMLAssociationList compositions = c->getCompositions();

    //Write class Documentation
  if(forceDoc() || !c->getDoc().isEmpty()) {
    perl << m_endl << "=head1";
    perl << " " << classname.upper() << m_endl << m_endl;
    perl << c->getDoc();
    perl << m_endl << m_endl << "=cut" << m_endl << m_endl;
  }

  //check if class is abstract and / or has abstract methods
  if(c->getAbstract())
    perl << "=head1 ABSTRACT CLASS" << m_endl << m_endl << "=cut" << m_endl;

  //attributes
  if (! c->isInterface())
    writeAttributes(c, perl);      // keep for documentation's sake

  //operations
  writeOperations(c,perl);

  perl << m_endl;

  //finish file
  //perl << m_endl << m_endl << "=cut" << m_endl;
  perl << m_endl << m_endl << "return 1;" << m_endl;

  //close files and notify we are done
  fileperl.close();
  emit codeGenerated(c, true);
}

/**
 * returns "Perl"
 */
Uml::Programming_Language PerlWriter::getLanguage() {
    return Uml::pl_Perl;
}

////////////////////////////////////////////////////////////////////////////////////
//  Helper Methods

void PerlWriter::writeOperations(UMLClassifier *c, TQTextStream &perl) {

    //Lists to store operations  sorted by scope
    UMLOperationList oppub,opprot,oppriv;

    oppub.setAutoDelete(false);
    opprot.setAutoDelete(false);
    oppriv.setAutoDelete(false);

    //sort operations by scope first and see if there are abstract methods
    //keep this for documentation only!
    UMLOperationList opl(c->getOpList());
    for(UMLOperation *op = opl.first(); op ; op = opl.next()) {
        switch(op->getVisibility()) {
          case Uml::Visibility::Public:
            oppub.append(op);
            break;
          case Uml::Visibility::Protected:
            opprot.append(op);
            break;
          case Uml::Visibility::Private:
            oppriv.append(op);
            break;
          default:
            break;
        }
    }

    TQString classname(cleanName(c->getName()));

    //write operations to file
    if(forceSections() || !oppub.isEmpty()) {
        perl << m_endl << "=head1 PUBLIC METHODS" << m_endl << m_endl ;
        writeOperations(classname,oppub,perl);
        perl << m_endl << m_endl << "=cut" << m_endl << m_endl;
    }

    if(forceSections() || !opprot.isEmpty()) {
        perl << m_endl << "=head1 METHODS FOR SUBCLASSING" << m_endl << m_endl ;
        //perl << "=pod "  << m_endl << m_endl << "=head3 " ;
        writeOperations(classname,opprot,perl);
        perl << m_endl << m_endl << "=cut" << m_endl << m_endl;
    }

    if(forceSections() || !oppriv.isEmpty()) {
        perl << m_endl << "=head1 PRIVATE METHODS" << m_endl << m_endl ;
        //perl << "=pod "  << m_endl << m_endl << "=head3 " ;
        writeOperations(classname,oppriv,perl);
        perl << m_endl << m_endl << "=cut" << m_endl << m_endl;
    }

    // moved here for perl
    if (!c->isInterface() && hasDefaultValueAttr(c)) {
        UMLAttributeList atl = c->getAttributeList();

        perl << m_endl;
        perl << m_endl << "=head2 _init" << m_endl << m_endl << m_endl;
        perl << "_init sets all " + classname + " attributes to their default values unless already set" << m_endl << m_endl << "=cut" << m_endl << m_endl;
        perl << "sub _init {" << m_endl << m_indentation << "my $self = shift;" << m_endl<<m_endl;

        for(UMLAttribute *at = atl.first(); at ; at = atl.next()) {
            if(!at->getInitialValue().isEmpty())
                perl << m_indentation << "defined $self->{" << cleanName(at->getName())<<"}"
                << " or $self->{" << cleanName(at->getName()) << "} = "
                << at->getInitialValue() << ";" << m_endl;
        }

        perl << " }" << m_endl;
    }

    perl << m_endl << m_endl;
}

void PerlWriter::writeOperations(const TQString &/* classname */, UMLOperationList &opList, TQTextStream &perl) {
    UMLOperation *op;
    UMLAttribute *at;

    for(op=opList.first(); op ; op=opList.next())
    {
        UMLAttributeList atl = op->getParmList();
        //write method doc if we have doc || if at least one of the params has doc
        bool writeDoc = forceDoc() || !op->getDoc().isEmpty();
        for (at = atl.first(); at ; at = atl.next())
            writeDoc |= !at->getDoc().isEmpty();

        if( writeDoc )  //write method documentation
        {
            perl << "=pod "  << m_endl << m_endl << "=head3 " ;
            perl << cleanName(op->getName()) << m_endl << m_endl;

            perl << "   Parameters :" << m_endl ;
          //write parameter documentation
          for (at = atl.first(); at ; at = atl.next()) {
            if(forceDoc() || !at->getDoc().isEmpty()) {
              perl << "      "
                   << cleanName(at->getName()) << " : "
                   << at->getTypeName() << " : "
                   << at->getDoc()
                   << m_endl;
                }
            }//end for : write parameter documentation

            perl << m_endl;
            perl << "   Return : " << m_endl;
            perl << "      " << op->getTypeName();
            perl << m_endl << m_endl;
            perl << "   Description : " << m_endl;
            perl << "      " << op->getDoc();
            perl << m_endl << m_endl << "=cut" << m_endl << m_endl;
        }//end if : write method documentation

        perl <<  "sub " << cleanName(op->getName()) << m_endl << "{" << m_endl;
        perl << "  my($self";

        bool bStartPrinted = false;
        //write parameters
        for (at = atl.first(); at; at = atl.next()) {
          if (!bStartPrinted) {
              bStartPrinted = true;
              perl << "," << m_endl;
          }
          perl << "     $"<< cleanName(at->getName()) << ", # "
               << at->getTypeName() << " : " << at->getDoc() << m_endl;
        }

        perl << "    ) = @_;" << m_endl;

        perl << "#UML_MODELER_BEGIN_PERSONAL_CODE_" << cleanName(op->getName());
        perl << m_endl << "#UML_MODELER_END_PERSONAL_CODE_" << cleanName(op->getName()) << m_endl;
        perl << "}" << m_endl;
        perl << m_endl << m_endl;
    }//end for
}


void PerlWriter::writeAttributes(UMLClassifier *c, TQTextStream &perl) {
    UMLAttributeList  atpub, atprot, atpriv, atdefval;
    atpub.setAutoDelete(false);
    atprot.setAutoDelete(false);
    atpriv.setAutoDelete(false);
    atdefval.setAutoDelete(false);

    //sort attributes by scope and see if they have a default value
    UMLAttributeList atl = c->getAttributeList();
    UMLAttribute *at;
    for(at = atl.first(); at ; at = atl.next()) {
        if(!at->getInitialValue().isEmpty())
            atdefval.append(at);
        switch(at->getVisibility()) {
          case Uml::Visibility::Public:
            atpub.append(at);
            break;
          case Uml::Visibility::Protected:
            atprot.append(at);
            break;
          case Uml::Visibility::Private:
            atpriv.append(at);
            break;
          default:
            break;
        }
    }


    if(forceSections() || atpub.count()) {
        writeAttributes(atpub,perl);
    }
    /* not needed as writeAttributes only writes documentation
    if(forceSections() || atprot.count()) {
    writeAttributes(atprot,perl);
    }

    if(forceSections() || atpriv.count()) {
    writeAttributes(atpriv,perl);
    }
    */
}


void PerlWriter::writeAttributes(UMLAttributeList &atList, TQTextStream &perl)
{
    perl << m_endl << "=head1 PUBLIC ATTRIBUTES" << m_endl << m_endl;
    perl << "=pod "  << m_endl << m_endl ;
    for (UMLAttribute *at = atList.first(); at ; at = atList.next())
    {
        if (forceDoc() || !at->getDoc().isEmpty())
        {
            perl  << "=head3 " << cleanName(at->getName()) << m_endl << m_endl ;
            perl  << "   Description : " << at->getDoc() << m_endl << m_endl;
        }
    } // end for
    perl << m_endl << m_endl << "=cut" << m_endl << m_endl;
    return;
}

TQStringList PerlWriter::defaultDatatypes() {
    TQStringList l;
    l.append("$");
    l.append("@");
    l.append("%");
    return l;
}

const TQStringList PerlWriter::reservedKeywords() const {

    static TQStringList keywords;

    if (keywords.isEmpty()) {
        keywords << "abs"
        << "accept"
        << "alarm"
        << "and"
        << "atan2"
        << "BEGIN"
        << "bind"
        << "binmode"
        << "bless"
        << "byte"
        << "caller"
        << "carp"
        << "chdir"
        << "chmod"
        << "chomp"
        << "chop"
        << "chown"
        << "chr"
        << "chroot"
        << "close"
        << "closedir"
        << "cmp"
        << "confess"
        << "connect"
        << "continue"
        << "cos"
        << "croak"
        << "crypt"
        << "dbmclose"
        << "dbmopen"
        << "defined"
        << "delete"
        << "die"
        << "do"
        << "dump"
        << "each"
        << "else"
        << "elsif"
        << "END"
        << "endgrent"
        << "endhostent"
        << "endnetent"
        << "endprotoent"
        << "endpwent"
        << "endservent"
        << "eof"
        << "eq"
        << "eval"
        << "exec"
        << "exists"
        << "exit"
        << "exp"
        << "fcntl"
        << "fileno"
        << "flock"
        << "for"
        << "foreach"
        << "fork"
        << "format"
        << "formline"
        << "ge"
        << "getc"
        << "getgrent"
        << "getgrgid"
        << "getgrnam"
        << "gethostbyaddr"
        << "gethostbyname"
        << "gethostent"
        << "getlogin"
        << "getnetbyaddr"
        << "getnetbyname"
        << "getnetent"
        << "getpeername"
        << "getpgrp"
        << "getppid"
        << "getpriority"
        << "getprotobyname"
        << "getprotobynumber"
        << "getprotoent"
        << "getpwent"
        << "getpwnam"
        << "getpwuid"
        << "getservbyname"
        << "getservbyport"
        << "getservent"
        << "getsockname"
        << "getsockopt"
        << "glob"
        << "gmtime"
        << "goto"
        << "grep"
        << "gt"
        << "hex"
        << "if"
        << "import"
        << "index"
        << "int"
        << "integer"
        << "ioctl"
        << "join"
        << "keys"
        << "kill"
        << "last"
        << "lc"
        << "lcfirst"
        << "le"
        << "length"
        << "lib"
        << "link"
        << "listen"
        << "local"
        << "localtime"
        << "lock"
        << "log"
        << "lstat"
        << "lt"
        << "map"
        << "mkdir"
        << "msgctl"
        << "msgget"
        << "msgrcv"
        << "msgsnd"
        << "my"
        << "ne"
        << "new"
        << "next"
        << "no"
        << "not"
        << "oct"
        << "open"
        << "opendir"
        << "or"
        << "ord"
        << "our"
        << "pack"
        << "package"
        << "pipe"
        << "pop"
        << "pos"
        << "print"
        << "printf"
        << "prototype"
        << "push"
        << "quotemeta"
        << "rand"
        << "read"
        << "readdir"
        << "readline"
        << "readlink"
        << "readpipe"
        << "recv"
        << "redo"
        << "ref"
        << "rename"
        << "require"
        << "reset"
        << "return"
        << "reverse"
        << "rewinddir"
        << "rindex"
        << "rmdir"
        << "scalar"
        << "seek"
        << "seekdir"
        << "select"
        << "semctl"
        << "semget"
        << "semop"
        << "send"
        << "setgrent"
        << "sethostent"
        << "setnetent"
        << "setpgrp"
        << "setpriority"
        << "setprotoent"
        << "setpwent"
        << "setservent"
        << "setsockopt"
        << "shift"
        << "shmctl"
        << "shmget"
        << "shmread"
        << "shmwrite"
        << "shutdown"
        << "sigtrap"
        << "sin"
        << "sleep"
        << "socket"
        << "socketpair"
        << "sort"
        << "splice"
        << "split"
        << "sprintf"
        << "sqrt"
        << "srand"
        << "stat"
        << "strict"
        << "study"
        << "sub"
        << "subs"
        << "substr"
        << "switch"
        << "symlink"
        << "syscall"
        << "sysopen"
        << "sysread"
        << "sysseek"
        << "system"
        << "syswrite"
        << "tell"
        << "telldir"
        << "tie"
        << "tied"
        << "time"
        << "times"
        << "truncate"
        << "uc"
        << "ucfirst"
        << "umask"
        << "undef"
        << "unless"
        << "unlink"
        << "unpack"
        << "unshift"
        << "untie"
        << "until"
        << "use"
        << "utf8"
        << "utime"
        << "values"
        << "vars"
        << "vec"
        << "wait"
        << "waitpid"
        << "wantarray"
        << "warn"
        << "warnings"
        << "while"
        << "write"
        << "xor";
    }

    return keywords;
}

#include "perlwriter.moc"