basic/source/runtime/step0.cxx

   1 /*************************************************************************
   2  *
   3  * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
   4  *
   5  * Copyright 2008 by Sun Microsystems, Inc.
   6  *
   7  * OpenOffice.org - a multi-platform office productivity suite
   8  *
   9  * $RCSfile: step0.cxx,v $
  10  * $Revision: 1.32 $
  11  *
  12  * This file is part of OpenOffice.org.
  13  *
  14  * OpenOffice.org is free software: you can redistribute it and/or modify
  15  * it under the terms of the GNU Lesser General Public License version 3
  16  * only, as published by the Free Software Foundation.
  17  *
  18  * OpenOffice.org is distributed in the hope that it will be useful,
  19  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  20  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21  * GNU Lesser General Public License version 3 for more details
  22  * (a copy is included in the LICENSE file that accompanied this code).
  23  *
  24  * You should have received a copy of the GNU Lesser General Public License
  25  * version 3 along with OpenOffice.org.  If not, see
  26  * <http://www.openoffice.org/license.html>
  27  * for a copy of the LGPLv3 License.
  28  *
  29  ************************************************************************/
  30
  31 // MARKER(update_precomp.py): autogen include statement, do not remove
  32 #include "precompiled_basic.hxx"
  33 #include <vcl/msgbox.hxx>
  34 #include <tools/fsys.hxx>
  35
  36 #include "errobject.hxx"
  37 #include "runtime.hxx"
  38 #include "sbintern.hxx"
  39 #include "iosys.hxx"
  40 #include <sb.hrc>
  41 #include <basrid.hxx>
  42 #include "sbunoobj.hxx"
  43 #include "image.hxx"
  44 #include <com/sun/star/uno/Any.hxx>
  45 #include <com/sun/star/util/SearchOptions.hdl>
  46 #include <vcl/svapp.hxx>
  47 #include <unotools/textsearch.hxx>
  48
  49 #include <algorithm>
  50
  51 // for a patch forward declaring these methods below makes sense
  52 // but, #FIXME lets really just move the methods to the top
  53 void lcl_clearImpl( SbxVariableRef& refVar, SbxDataType& eType );
  54 void lcl_eraseImpl( SbxVariableRef& refVar, bool bVBAEnabled );
  55
  56 SbxVariable* getDefaultProp( SbxVariable* pRef );
  57
  58 void SbiRuntime::StepNOP()
  59 {}
  60
  61 void SbiRuntime::StepArith( SbxOperator eOp )
  62 {
  63     SbxVariableRef p1 = PopVar();
  64     TOSMakeTemp();
  65     SbxVariable* p2 = GetTOS();
  66
  67     p2->ResetFlag( SBX_FIXED );
  68     p2->Compute( eOp, *p1 );
  69
  70     checkArithmeticOverflow( p2 );
  71 }
  72
  73 void SbiRuntime::StepUnary( SbxOperator eOp )
  74 {
  75     TOSMakeTemp();
  76     SbxVariable* p = GetTOS();
  77     p->Compute( eOp, *p );
  78 }
  79
  80 void SbiRuntime::StepCompare( SbxOperator eOp )
  81 {
  82     SbxVariableRef p1 = PopVar();
  83     SbxVariableRef p2 = PopVar();
  84
  85     // Make sure objects with default params have
  86     // values ( and type ) set as appropriate
  87     SbxDataType p1Type = p1->GetType();
  88     SbxDataType p2Type = p2->GetType();
  89         if ( p1Type == SbxEMPTY )
  90         {
  91             p1->Broadcast( SBX_HINT_DATAWANTED );
  92                 p1Type = p1->GetType();
  93         }
  94         if ( p2Type == SbxEMPTY )
  95         {
  96             p2->Broadcast( SBX_HINT_DATAWANTED );
  97                 p2Type = p2->GetType();
  98         }
  99         if ( p1Type == p2Type )
 100         {
 101         // if both sides are an object and have default props
 102         // then we need to use the default props
 103         // we don't need to worry if only one side ( lhs, rhs ) is an
 104         // object ( object side will get coerced to correct type in
 105         // Compare )
 106                 if ( p1Type ==  SbxOBJECT )
 107         {
 108             SbxVariable* pDflt = getDefaultProp( p1 );
 109             if ( pDflt )
 110             {
 111                 p1 = pDflt;
 112                 p1->Broadcast( SBX_HINT_DATAWANTED );
 113             }
 114             pDflt = getDefaultProp( p2 );
 115             if ( pDflt )
 116             {
 117                 p2 = pDflt;
 118                 p2->Broadcast( SBX_HINT_DATAWANTED );
 119             }
 120         }
 121
 122     }
 123 #ifndef WIN
 124     static SbxVariable* pTRUE = NULL;
 125     static SbxVariable* pFALSE = NULL;
 126         static SbxVariable* pNULL = NULL;
 127         // why do this on non-windows ?
 128         // why do this at all ?
 129         // I dumbly follow the pattern :-/
 130         if ( bVBAEnabled && ( p1->IsNull() || p2->IsNull() ) )
 131     {
 132                 if( !pNULL )
 133                 {
 134                         pNULL = new SbxVariable;
 135                         pNULL->PutNull();
 136                         pNULL->AddRef();
 137                 }
 138                 PushVar( pNULL );
 139         }
 140         else if( p2->Compare( eOp, *p1 ) )
 141         {
 142         if( !pTRUE )
 143         {
 144             pTRUE = new SbxVariable;
 145             pTRUE->PutBool( TRUE );
 146             pTRUE->AddRef();
 147         }
 148         PushVar( pTRUE );
 149     }
 150     else
 151     {
 152         if( !pFALSE )
 153         {
 154             pFALSE = new SbxVariable;
 155             pFALSE->PutBool( FALSE );
 156             pFALSE->AddRef();
 157         }
 158         PushVar( pFALSE );
 159     }
 160 #else
 161         SbxVariable* pRes = new SbxVariable;
 162         if ( bVBAEnabled && ( p1->IsNull() || p2->IsNull() ) )
 163                 pRes->PutNull();
 164         else
 165         {
 166     BOOL bRes = p2->Compare( eOp, *p1 );
 167     pRes->PutBool( bRes );
 168         }
 169     PushVar( pRes );
 170 #endif
 171 }
 172
 173 void SbiRuntime::StepEXP()              { StepArith( SbxEXP );          }
 174 void SbiRuntime::StepMUL()              { StepArith( SbxMUL );          }
 175 void SbiRuntime::StepDIV()              { StepArith( SbxDIV );          }
 176 void SbiRuntime::StepIDIV()             { StepArith( SbxIDIV );         }
 177 void SbiRuntime::StepMOD()              { StepArith( SbxMOD );          }
 178 void SbiRuntime::StepPLUS()             { StepArith( SbxPLUS );         }
 179 void SbiRuntime::StepMINUS()            { StepArith( SbxMINUS );        }
 180 void SbiRuntime::StepCAT()              { StepArith( SbxCAT );          }
 181 void SbiRuntime::StepAND()              { StepArith( SbxAND );          }
 182 void SbiRuntime::StepOR()               { StepArith( SbxOR );           }
 183 void SbiRuntime::StepXOR()              { StepArith( SbxXOR );          }
 184 void SbiRuntime::StepEQV()              { StepArith( SbxEQV );          }
 185 void SbiRuntime::StepIMP()              { StepArith( SbxIMP );          }
 186
 187 void SbiRuntime::StepNEG()              { StepUnary( SbxNEG );          }
 188 void SbiRuntime::StepNOT()              { StepUnary( SbxNOT );          }
 189
 190 void SbiRuntime::StepEQ()               { StepCompare( SbxEQ );         }
 191 void SbiRuntime::StepNE()               { StepCompare( SbxNE );         }
 192 void SbiRuntime::StepLT()               { StepCompare( SbxLT );         }
 193 void SbiRuntime::StepGT()               { StepCompare( SbxGT );         }
 194 void SbiRuntime::StepLE()               { StepCompare( SbxLE );         }
 195 void SbiRuntime::StepGE()               { StepCompare( SbxGE );         }
 196
 197 namespace
 198 {
 199     bool NeedEsc(sal_Unicode cCode)
 200     {
 201         String sEsc(RTL_CONSTASCII_USTRINGPARAM(".^$+\\|{}()"));
 202         return (STRING_NOTFOUND != sEsc.Search(cCode));
 203     }
 204
 205     String VBALikeToRegexp(const String &rIn)
 206     {
 207         String sResult;
 208         const sal_Unicode *start = rIn.GetBuffer();
 209         const sal_Unicode *end = start + rIn.Len();
 210
 211         int seenright = 0;
 212
 213         sResult.Append('^');
 214
 215         while (start < end)
 216         {
 217             switch (*start)
 218             {
 219                 case '?':
 220                     sResult.Append('.');
 221                     start++;
 222                     break;
 223                 case '*':
 224                     sResult.Append(String(RTL_CONSTASCII_USTRINGPARAM(".*")));
 225                     start++;
 226                     break;
 227                 case '#':
 228                     sResult.Append(String(RTL_CONSTASCII_USTRINGPARAM("[0-9]")));
 229                     start++;
 230                     break;
 231                 case ']':
 232                     sResult.Append('\\');
 233                     sResult.Append(*start++);
 234                     break;
 235                 case '[':
 236                     sResult.Append(*start++);
 237                     seenright = 0;
 238                     while (start < end && !seenright)
 239                     {
 240                         switch (*start)
 241                         {
 242                             case '[':
 243                             case '?':
 244                             case '*':
 245                             sResult.Append('\\');
 246                             sResult.Append(*start);
 247                                 break;
 248                             case ']':
 249                             sResult.Append(*start);
 250                                 seenright = 1;
 251                                 break;
 252                             case '!':
 253                                 sResult.Append('^');
 254                                 break;
 255                             default:
 256                             if (NeedEsc(*start))
 257                                     sResult.Append('\\');
 258                             sResult.Append(*start);
 259                                 break;
 260                         }
 261                         start++;
 262                     }
 263                     break;
 264                 default:
 265                     if (NeedEsc(*start))
 266                         sResult.Append('\\');
 267                     sResult.Append(*start++);
 268             }
 269         }
 270
 271         sResult.Append('$');
 272
 273         return sResult;
 274     }
 275 }
 276
 277 void SbiRuntime::StepLIKE()
 278 {
 279     SbxVariableRef refVar1 = PopVar();
 280     SbxVariableRef refVar2 = PopVar();
 281
 282     String pattern = VBALikeToRegexp(refVar1->GetString());
 283     String value = refVar2->GetString();
 284
 285     com::sun::star::util::SearchOptions aSearchOpt;
 286
 287     aSearchOpt.algorithmType = com::sun::star::util::SearchAlgorithms_REGEXP;
 288
 289     aSearchOpt.Locale = Application::GetSettings().GetLocale();
 290     aSearchOpt.searchString = pattern;
 291
 292     int bTextMode(1);
 293     bool bCompatibility = ( pINST && pINST->IsCompatibility() );
 294     if( bCompatibility )
 295         bTextMode = GetImageFlag( SBIMG_COMPARETEXT );
 296
 297     if( bTextMode )
 298         aSearchOpt.transliterateFlags |= com::sun::star::i18n::TransliterationModules_IGNORE_CASE;
 299
 300     SbxVariable* pRes = new SbxVariable;
 301     utl::TextSearch aSearch(aSearchOpt);
 302     xub_StrLen nStart=0, nEnd=value.Len();
 303     int bRes = aSearch.SearchFrwrd(value, &nStart, &nEnd);
 304     pRes->PutBool( bRes != 0 );
 305
 306     PushVar( pRes );
 307 }
 308
 309 // TOS und TOS-1 sind beides Objektvariable und enthalten den selben Pointer
 310
 311 void SbiRuntime::StepIS()
 312 {
 313     SbxVariableRef refVar1 = PopVar();
 314     SbxVariableRef refVar2 = PopVar();
 315     BOOL bRes = BOOL(
 316         refVar1->GetType() == SbxOBJECT
 317      && refVar2->GetType() == SbxOBJECT );
 318     if ( bVBAEnabled  && !bRes )
 319         Error( SbERR_INVALID_USAGE_OBJECT );
 320     bRes = ( bRes && refVar1->GetObject() == refVar2->GetObject() );
 321     SbxVariable* pRes = new SbxVariable;
 322     pRes->PutBool( bRes );
 323     PushVar( pRes );
 324 }
 325
 326 // Aktualisieren des Wertes von TOS
 327
 328 void SbiRuntime::StepGET()
 329 {
 330     SbxVariable* p = GetTOS();
 331     p->Broadcast( SBX_HINT_DATAWANTED );
 332 }
 333
 334 // #67607 Uno-Structs kopieren
 335 inline void checkUnoStructCopy( SbxVariableRef& refVal, SbxVariableRef& refVar )
 336 {
 337     SbxDataType eVarType = refVar->GetType();
 338     if( eVarType != SbxOBJECT )
 339         return;
 340
 341     SbxObjectRef xValObj = (SbxObject*)refVal->GetObject();
 342     if( !xValObj.Is() || xValObj->ISA(SbUnoAnyObject) )
 343         return;
 344
 345     // #115826: Exclude ProcedureProperties to avoid call to Property Get procedure
 346     if( refVar->ISA(SbProcedureProperty) )
 347         return;
 348
 349     SbxObjectRef xVarObj = (SbxObject*)refVar->GetObject();
 350     SbxDataType eValType = refVal->GetType();
 351     if( eValType == SbxOBJECT && xVarObj == xValObj )
 352     {
 353         SbUnoObject* pUnoObj = PTR_CAST(SbUnoObject,(SbxObject*)xVarObj);
 354         if( pUnoObj )
 355         {
 356             Any aAny = pUnoObj->getUnoAny();
 357             if( aAny.getValueType().getTypeClass() == TypeClass_STRUCT )
 358             {
 359                 SbUnoObject* pNewUnoObj = new SbUnoObject( pUnoObj->GetName(), aAny );
 360                 // #70324: ClassName uebernehmen
 361                 pNewUnoObj->SetClassName( pUnoObj->GetClassName() );
 362                 refVar->PutObject( pNewUnoObj );
 363             }
 364         }
 365     }
 366 }
 367
 368
 369 // Ablage von TOS in TOS-1
 370
 371 void SbiRuntime::StepPUT()
 372 {
 373     SbxVariableRef refVal = PopVar();
 374     SbxVariableRef refVar = PopVar();
 375     // Store auf die eigene Methode (innerhalb einer Function)?
 376     BOOL bFlagsChanged = FALSE;
 377     USHORT n = 0;
 378     if( (SbxVariable*) refVar == (SbxVariable*) pMeth )
 379     {
 380         bFlagsChanged = TRUE;
 381         n = refVar->GetFlags();
 382         refVar->SetFlag( SBX_WRITE );
 383     }
 384
 385     // if left side arg is an object or variant and right handside isn't
 386     // either an object or a variant then try and see if a default
 387     // property exists.
 388     // to use e.g. Range{"A1") = 34
 389     // could equate to Range("A1").Value = 34
 390     if ( bVBAEnabled )
 391     {
 392         if ( refVar->GetType() == SbxOBJECT  )
 393         {
 394             SbxVariable* pDflt = getDefaultProp( refVar );
 395             if ( pDflt )
 396                 refVar = pDflt;
 397         }
 398         if (  refVal->GetType() == SbxOBJECT  )
 399         {
 400             SbxVariable* pDflt = getDefaultProp( refVal );
 401             if ( pDflt )
 402                 refVal = pDflt;
 403         }
 404     }
 405
 406     *refVar = *refVal;
 407     // lhs is a property who's value is currently null
 408     if ( !bVBAEnabled || ( bVBAEnabled && refVar->GetType() != SbxEMPTY ) )
 409     // #67607 Uno-Structs kopieren
 410         checkUnoStructCopy( refVal, refVar );
 411     if( bFlagsChanged )
 412         refVar->SetFlags( n );
 413 }
 414
 415
 416 // Speichern Objektvariable
 417 // Nicht-Objekt-Variable fuehren zu Fehlern
 418
 419 void SbiRuntime::StepSET_Impl( SbxVariableRef& refVal, SbxVariableRef& refVar, bool bHandleDefaultProp )
 420 {
 421     // #67733 Typen mit Array-Flag sind auch ok
 422     SbxDataType eValType = refVal->GetType();
 423     SbxDataType eVarType = refVar->GetType();
 424         if( (eValType != SbxOBJECT
 425             && eValType != SbxEMPTY
 426 // seems like when using the default method its possible for objects
 427 // to be empty ( no broadcast has taken place yet ) or the actual value is
 428
 429             && !bHandleDefaultProp
 430             && !(eValType & SbxARRAY)) ||
 431             (eVarType != SbxOBJECT
 432             && eVarType != SbxEMPTY
 433             && !bHandleDefaultProp
 434             && !(eVarType & SbxARRAY) ) )
 435     {
 436         Error( SbERR_INVALID_USAGE_OBJECT );
 437     }
 438     else
 439     {
 440         // Getting in here causes problems with objects with default properties
 441         // if they are SbxEMPTY I guess
 442         if ( !bHandleDefaultProp || ( bHandleDefaultProp && refVal->GetType() == SbxOBJECT ) )
 443         {
 444         // Auf refVal GetObject fuer Collections ausloesen
 445             SbxBase* pObjVarObj = refVal->GetObject();
 446             if( pObjVarObj )
 447             {
 448                 SbxVariableRef refObjVal = PTR_CAST(SbxObject,pObjVarObj);
 449
 450                 // #67733 Typen mit Array-Flag sind auch ok
 451                 if( refObjVal )
 452                     refVal = refObjVal;
 453                 else if( !(eValType & SbxARRAY) )
 454                     refVal = NULL;
 455             }
 456         }
 457
 458         // #52896 Wenn Uno-Sequences bzw. allgemein Arrays einer als
 459         // Object deklarierten Variable zugewiesen werden, kann hier
 460         // refVal ungueltig sein!
 461         if( !refVal )
 462         {
 463             Error( SbERR_INVALID_USAGE_OBJECT );
 464         }
 465         else
 466         {
 467             // Store auf die eigene Methode (innerhalb einer Function)?
 468             BOOL bFlagsChanged = FALSE;
 469             USHORT n = 0;
 470             if( (SbxVariable*) refVar == (SbxVariable*) pMeth )
 471             {
 472                 bFlagsChanged = TRUE;
 473                 n = refVar->GetFlags();
 474                 refVar->SetFlag( SBX_WRITE );
 475             }
 476             SbProcedureProperty* pProcProperty = PTR_CAST(SbProcedureProperty,(SbxVariable*)refVar);
 477             if( pProcProperty )
 478                 pProcProperty->setSet( true );
 479
 480             if ( bHandleDefaultProp )
 481             {
 482                 // get default properties for lhs & rhs where necessary
 483                 // SbxVariable* defaultProp = NULL; unused variable
 484                 bool bLHSHasDefaultProp = false;
 485                 // LHS try determine if a default prop exists
 486                 if ( refVar->GetType() == SbxOBJECT )
 487                 {
 488                     SbxVariable* pDflt = getDefaultProp( refVar );
 489                     if ( pDflt )
 490                     {
 491                         refVar = pDflt;
 492                         bLHSHasDefaultProp = true;
 493                     }
 494                 }
 495                 // RHS only get a default prop is the rhs has one
 496                 if (  refVal->GetType() == SbxOBJECT )
 497                 {
 498                     // check if lhs is a null object
 499                     // if it is then use the object not the default property
 500                     SbxObject* pObj = NULL;
 501
 502
 503                     pObj = PTR_CAST(SbxObject,(SbxVariable*)refVar);
 504
 505                     // calling GetObject on a SbxEMPTY variable raises
 506                     // object not set errors, make sure its an Object
 507                     if ( !pObj && refVar->GetType() == SbxOBJECT )
 508                     {
 509                         SbxBase* pObjVarObj = refVar->GetObject();
 510                         pObj = PTR_CAST(SbxObject,pObjVarObj);
 511                     }
 512                     SbxVariable* pDflt = NULL;
 513                     if ( pObj || bLHSHasDefaultProp )
 514                         // lhs is either a valid object || or has a defaultProp
 515                         pDflt = getDefaultProp( refVal );
 516                     if ( pDflt )
 517                         refVal = pDflt;
 518                 }
 519             }
 520
 521             *refVar = *refVal;
 522
 523             // lhs is a property who's value is currently (Empty e.g. no broadcast yet)
 524             // in this case if there is a default prop involved the value of the
 525             // default property may infact be void so the type will also be SbxEMPTY
 526             // in this case we do not want to call checkUnoStructCopy 'cause that will
 527             // cause an error also
 528             if ( !bHandleDefaultProp || ( bHandleDefaultProp && ( refVar->GetType() != SbxEMPTY ) ) )
 529             // #67607 Uno-Structs kopieren
 530                 checkUnoStructCopy( refVal, refVar );
 531             if( bFlagsChanged )
 532                 refVar->SetFlags( n );
 533         }
 534     }
 535 }
 536
 537 void SbiRuntime::StepSET()
 538 {
 539     SbxVariableRef refVal = PopVar();
 540     SbxVariableRef refVar = PopVar();
 541     StepSET_Impl( refVal, refVar, bVBAEnabled ); // this is really assigment
 542 }
 543
 544 void SbiRuntime::StepVBASET()
 545 {
 546     SbxVariableRef refVal = PopVar();
 547     SbxVariableRef refVar = PopVar();
 548     // don't handle default property
 549     StepSET_Impl( refVal, refVar, false ); // set obj = something
 550 }
 551
 552
 553 // JSM 07.10.95
 554 void SbiRuntime::StepLSET()
 555 {
 556     SbxVariableRef refVal = PopVar();
 557     SbxVariableRef refVar = PopVar();
 558     if( refVar->GetType() != SbxSTRING
 559      || refVal->GetType() != SbxSTRING )
 560         Error( SbERR_INVALID_USAGE_OBJECT );
 561     else
 562     {
 563         // Store auf die eigene Methode (innerhalb einer Function)?
 564         USHORT n = refVar->GetFlags();
 565         if( (SbxVariable*) refVar == (SbxVariable*) pMeth )
 566             refVar->SetFlag( SBX_WRITE );
 567         String aRefVarString = refVar->GetString();
 568         String aRefValString = refVal->GetString();
 569
 570         USHORT nVarStrLen = aRefVarString.Len();
 571         USHORT nValStrLen = aRefValString.Len();
 572         String aNewStr;
 573         if( nVarStrLen > nValStrLen )
 574         {
 575             aRefVarString.Fill(nVarStrLen,' ');
 576             aNewStr  = aRefValString.Copy( 0, nValStrLen );
 577             aNewStr += aRefVarString.Copy( nValStrLen, nVarStrLen - nValStrLen );
 578         }
 579         else
 580         {
 581             aNewStr = aRefValString.Copy( 0, nVarStrLen );
 582         }
 583
 584         refVar->PutString( aNewStr );
 585         refVar->SetFlags( n );
 586     }
 587 }
 588
 589 // JSM 07.10.95
 590 void SbiRuntime::StepRSET()
 591 {
 592     SbxVariableRef refVal = PopVar();
 593     SbxVariableRef refVar = PopVar();
 594     if( refVar->GetType() != SbxSTRING
 595      || refVal->GetType() != SbxSTRING )
 596         Error( SbERR_INVALID_USAGE_OBJECT );
 597     else
 598     {
 599         // Store auf die eigene Methode (innerhalb einer Function)?
 600         USHORT n = refVar->GetFlags();
 601         if( (SbxVariable*) refVar == (SbxVariable*) pMeth )
 602             refVar->SetFlag( SBX_WRITE );
 603         String aRefVarString = refVar->GetString();
 604         String aRefValString = refVal->GetString();
 605
 606         USHORT nPos = 0;
 607         USHORT nVarStrLen = aRefVarString.Len();
 608         if( nVarStrLen > aRefValString.Len() )
 609         {
 610             aRefVarString.Fill(nVarStrLen,' ');
 611             nPos = nVarStrLen - aRefValString.Len();
 612         }
 613         aRefVarString  = aRefVarString.Copy( 0, nPos );
 614         aRefVarString += aRefValString.Copy( 0, nVarStrLen - nPos );
 615         refVar->PutString(aRefVarString);
 616
 617         refVar->SetFlags( n );
 618     }
 619 }
 620
 621 // Ablage von TOS in TOS-1, dann ReadOnly-Bit setzen
 622
 623 void SbiRuntime::StepPUTC()
 624 {
 625     SbxVariableRef refVal = PopVar();
 626     SbxVariableRef refVar = PopVar();
 627     refVar->SetFlag( SBX_WRITE );
 628     *refVar = *refVal;
 629     refVar->ResetFlag( SBX_WRITE );
 630     refVar->SetFlag( SBX_CONST );
 631 }
 632
 633 // DIM
 634 // TOS = Variable fuer das Array mit Dimensionsangaben als Parameter
 635
 636 void SbiRuntime::StepDIM()
 637 {
 638     SbxVariableRef refVar = PopVar();
 639     DimImpl( refVar );
 640 }
 641
 642 // #56204 DIM-Funktionalitaet in Hilfsmethode auslagern (step0.cxx)
 643 void SbiRuntime::DimImpl( SbxVariableRef refVar )
 644 {
 645         // If refDim then this DIM statement is terminating a ReDIM and
 646         // previous StepERASE_CLEAR for an array, the following actions have
 647         // been delayed from ( StepERASE_CLEAR ) 'till here
 648         if ( refRedim )
 649         {
 650                 if ( !refRedimpArray ) // only erase the array not ReDim Preserve
 651                         lcl_eraseImpl( refVar, bVBAEnabled );
 652                 SbxDataType eType = refVar->GetType();
 653                 lcl_clearImpl( refVar, eType );
 654                 refRedim = NULL;
 655         }
 656     SbxArray* pDims = refVar->GetParameters();
 657     // Muss eine gerade Anzahl Argumente haben
 658     // Man denke daran, dass Arg[0] nicht zaehlt!
 659     if( pDims && !( pDims->Count() & 1 ) )
 660         StarBASIC::FatalError( SbERR_INTERNAL_ERROR );
 661     else
 662     {
 663         SbxDataType eType = refVar->IsFixed() ? refVar->GetType() : SbxVARIANT;
 664         SbxDimArray* pArray = new SbxDimArray( eType );
 665         // AB 2.4.1996, auch Arrays ohne Dimensionsangaben zulassen (VB-komp.)
 666         if( pDims )
 667         {
 668             for( USHORT i = 1; i < pDims->Count(); )
 669             {
 670                 INT32 lb = pDims->Get( i++ )->GetLong();
 671                 INT32 ub = pDims->Get( i++ )->GetLong();
 672                 if( ub < lb )
 673                     Error( SbERR_OUT_OF_RANGE ), ub = lb;
 674                 pArray->AddDim32( lb, ub );
 675                 if ( lb != ub )
 676                     pArray->setHasFixedSize( true );
 677             }
 678         }
 679         else
 680         {
 681             // #62867 Beim Anlegen eines Arrays der Laenge 0 wie bei
 682             // Uno-Sequences der Laenge 0 eine Dimension anlegen
 683             pArray->unoAddDim( 0, -1 );
 684         }
 685         USHORT nSavFlags = refVar->GetFlags();
 686         refVar->ResetFlag( SBX_FIXED );
 687         refVar->PutObject( pArray );
 688         refVar->SetFlags( nSavFlags );
 689         refVar->SetParameters( NULL );
 690     }
 691 }
 692
 693 // REDIM
 694 // TOS  = Variable fuer das Array
 695 // argv = Dimensionsangaben
 696
 697 void SbiRuntime::StepREDIM()
 698 {
 699     // Im Moment ist es nichts anderes als Dim, da doppeltes Dim
 700     // bereits vom Compiler erkannt wird.
 701     StepDIM();
 702 }
 703
 704
 705 // Helper function for StepREDIMP
 706 void implCopyDimArray( SbxDimArray* pNewArray, SbxDimArray* pOldArray, short nMaxDimIndex,
 707     short nActualDim, sal_Int32* pActualIndices, sal_Int32* pLowerBounds, sal_Int32* pUpperBounds )
 708 {
 709     sal_Int32& ri = pActualIndices[nActualDim];
 710     for( ri = pLowerBounds[nActualDim] ; ri <= pUpperBounds[nActualDim] ; ri++ )
 711     {
 712         if( nActualDim < nMaxDimIndex )
 713         {
 714             implCopyDimArray( pNewArray, pOldArray, nMaxDimIndex, nActualDim + 1,
 715                 pActualIndices, pLowerBounds, pUpperBounds );
 716         }
 717         else
 718         {
 719             SbxVariable* pSource = pOldArray->Get32( pActualIndices );
 720             SbxVariable* pDest   = pNewArray->Get32( pActualIndices );
 721             if( pSource && pDest )
 722                 *pDest = *pSource;
 723         }
 724     }
 725 }
 726
 727 // REDIM PRESERVE
 728 // TOS  = Variable fuer das Array
 729 // argv = Dimensionsangaben
 730
 731 void SbiRuntime::StepREDIMP()
 732 {
 733     SbxVariableRef refVar = PopVar();
 734     DimImpl( refVar );
 735
 736     // Now check, if we can copy from the old array
 737     if( refRedimpArray.Is() )
 738     {
 739         SbxBase* pElemObj = refVar->GetObject();
 740         SbxDimArray* pNewArray = PTR_CAST(SbxDimArray,pElemObj);
 741         SbxDimArray* pOldArray = (SbxDimArray*)(SbxArray*)refRedimpArray;
 742         if( pNewArray )
 743         {
 744             short nDimsNew = pNewArray->GetDims();
 745             short nDimsOld = pOldArray->GetDims();
 746             short nDims = nDimsNew;
 747             BOOL bRangeError = FALSE;
 748
 749             // Store dims to use them for copying later
 750             sal_Int32* pLowerBounds = new sal_Int32[nDims];
 751             sal_Int32* pUpperBounds = new sal_Int32[nDims];
 752             sal_Int32* pActualIndices = new sal_Int32[nDims];
 753
 754             if( nDimsOld != nDimsNew )
 755             {
 756                 bRangeError = TRUE;
 757             }
 758             else
 759             {
 760                 // Compare bounds
 761                 for( short i = 1 ; i <= nDims ; i++ )
 762                 {
 763                     sal_Int32 lBoundNew, uBoundNew;
 764                     sal_Int32 lBoundOld, uBoundOld;
 765                     pNewArray->GetDim32( i, lBoundNew, uBoundNew );
 766                     pOldArray->GetDim32( i, lBoundOld, uBoundOld );
 767
 768                     /* #69094 Allow all dimensions to be changed
 769                        although Visual Basic is not able to do so.
 770                     // All bounds but the last have to be the same
 771                     if( i < nDims && ( lBoundNew != lBoundOld || uBoundNew != uBoundOld ) )
 772                     {
 773                         bRangeError = TRUE;
 774                         break;
 775                     }
 776                     else
 777                     */
 778                     {
 779                         // #69094: if( i == nDims )
 780                         {
 781                             lBoundNew = std::max( lBoundNew, lBoundOld );
 782                             uBoundNew = std::min( uBoundNew, uBoundOld );
 783                         }
 784                         short j = i - 1;
 785                         pActualIndices[j] = pLowerBounds[j] = lBoundNew;
 786                         pUpperBounds[j] = uBoundNew;
 787                     }
 788                 }
 789             }
 790
 791             if( bRangeError )
 792             {
 793                 StarBASIC::Error( SbERR_OUT_OF_RANGE );
 794             }
 795             else
 796             {
 797                 // Copy data from old array by going recursively through all dimensions
 798                 // (It would be faster to work on the flat internal data array of an
 799                 // SbyArray but this solution is clearer and easier)
 800                 implCopyDimArray( pNewArray, pOldArray, nDims - 1,
 801                     0, pActualIndices, pLowerBounds, pUpperBounds );
 802             }
 803
 804             delete[] pUpperBounds;
 805             delete[] pLowerBounds;
 806             delete[] pActualIndices;
 807             refRedimpArray = NULL;
 808         }
 809     }
 810
 811     //StarBASIC::FatalError( SbERR_NOT_IMPLEMENTED );
 812 }
 813
 814 // REDIM_COPY
 815 // TOS  = Array-Variable, Reference to array is copied
 816 //                Variable is cleared as in ERASE
 817
 818 void SbiRuntime::StepREDIMP_ERASE()
 819 {
 820     SbxVariableRef refVar = PopVar();
 821         refRedim = refVar;
 822     SbxDataType eType = refVar->GetType();
 823     if( eType & SbxARRAY )
 824     {
 825         SbxBase* pElemObj = refVar->GetObject();
 826         SbxDimArray* pDimArray = PTR_CAST(SbxDimArray,pElemObj);
 827         if( pDimArray )
 828         {
 829             refRedimpArray = pDimArray;
 830         }
 831
 832     }
 833     else
 834     if( refVar->IsFixed() )
 835         refVar->Clear();
 836     else
 837         refVar->SetType( SbxEMPTY );
 838 }
 839
 840 void lcl_clearImpl( SbxVariableRef& refVar, SbxDataType& eType )
 841 {
 842     USHORT nSavFlags = refVar->GetFlags();
 843     refVar->ResetFlag( SBX_FIXED );
 844     refVar->SetType( SbxDataType(eType & 0x0FFF) );
 845     refVar->SetFlags( nSavFlags );
 846     refVar->Clear();
 847 }
 848
 849 void lcl_eraseImpl( SbxVariableRef& refVar, bool bVBAEnabled )
 850 {
 851     SbxDataType eType = refVar->GetType();
 852     if( eType & SbxARRAY )
 853     {
 854         if ( bVBAEnabled )
 855         {
 856             SbxBase* pElemObj = refVar->GetObject();
 857             SbxDimArray* pDimArray = PTR_CAST(SbxDimArray,pElemObj);
 858             bool bClearValues = true;
 859             if( pDimArray )
 860             {
 861                 if ( pDimArray->hasFixedSize() )
 862                 {
 863                     // Clear all Value(s)
 864                     pDimArray->SbxArray::Clear();
 865                     bClearValues = false;
 866                 }
 867                 else
 868                     pDimArray->Clear(); // clear Dims
 869             }
 870             if ( bClearValues )
 871             {
 872                 SbxArray* pArray = PTR_CAST(SbxArray,pElemObj);
 873                 if ( pArray )
 874                     pArray->Clear();
 875             }
 876         }
 877         else
 878         // AB 2.4.1996
 879         // Arrays haben bei Erase nach VB ein recht komplexes Verhalten. Hier
 880         // werden zunaechst nur die Typ-Probleme bei REDIM (#26295) beseitigt:
 881         // Typ hart auf den Array-Typ setzen, da eine Variable mit Array
 882         // SbxOBJECT ist. Bei REDIM entsteht dann ein SbxOBJECT-Array und
 883         // der ursruengliche Typ geht verloren -> Laufzeitfehler
 884             lcl_clearImpl( refVar, eType );
 885     }
 886     else
 887     if( refVar->IsFixed() )
 888         refVar->Clear();
 889     else
 890         refVar->SetType( SbxEMPTY );
 891 }
 892
 893 // Variable loeschen
 894 // TOS = Variable
 895
 896 void SbiRuntime::StepERASE()
 897 {
 898     SbxVariableRef refVar = PopVar();
 899     lcl_eraseImpl( refVar, bVBAEnabled );
 900 }
 901
 902 void SbiRuntime::StepERASE_CLEAR()
 903 {
 904         refRedim = PopVar();
 905 }
 906
 907 void SbiRuntime::StepARRAYACCESS()
 908 {
 909     if( !refArgv )
 910         StarBASIC::FatalError( SbERR_INTERNAL_ERROR );
 911     SbxVariableRef refVar = PopVar();
 912     refVar->SetParameters( refArgv );
 913     PopArgv();
 914     PushVar( CheckArray( refVar ) );
 915 }
 916
 917 // Einrichten eines Argvs
 918 // nOp1 bleibt so -> 1. Element ist Returnwert
 919
 920 void SbiRuntime::StepARGC()
 921 {
 922     PushArgv();
 923     refArgv = new SbxArray;
 924     nArgc = 1;
 925 }
 926
 927 // Speichern eines Arguments in Argv
 928
 929 void SbiRuntime::StepARGV()
 930 {
 931     if( !refArgv )
 932         StarBASIC::FatalError( SbERR_INTERNAL_ERROR );
 933     else
 934     {
 935         SbxVariableRef pVal = PopVar();
 936
 937         // Before fix of #94916:
 938         // if( pVal->ISA(SbxMethod) || pVal->ISA(SbxProperty) )
 939         if( pVal->ISA(SbxMethod) || pVal->ISA(SbUnoProperty) || pVal->ISA(SbProcedureProperty) )
 940         {
 941             // Methoden und Properties evaluieren!
 942             SbxVariable* pRes = new SbxVariable( *pVal );
 943             pVal = pRes;
 944         }
 945         refArgv->Put( pVal, nArgc++ );
 946     }
 947 }
 948
 949 // Input to Variable. Die Variable ist auf TOS und wird
 950 // anschliessend entfernt.
 951
 952 void SbiRuntime::StepINPUT()
 953 {
 954     String s;
 955     char ch = 0;
 956     SbError err;
 957     // Skip whitespace
 958     while( ( err = pIosys->GetError() ) == 0 )
 959     {
 960         ch = pIosys->Read();
 961         if( ch != ' ' && ch != '\t' && ch != '\n' )
 962             break;
 963     }
 964     if( !err )
 965     {
 966         // Scan until comma or whitespace
 967         char sep = ( ch == '"' ) ? ch : 0;
 968         if( sep ) ch = pIosys->Read();
 969         while( ( err = pIosys->GetError() ) == 0 )
 970         {
 971             if( ch == sep )
 972             {
 973                 ch = pIosys->Read();
 974                 if( ch != sep )
 975                     break;
 976             }
 977             else if( !sep && (ch == ',' || ch == '\n') )
 978                 break;
 979             s += ch;
 980             ch = pIosys->Read();
 981         }
 982         // skip whitespace
 983         if( ch == ' ' || ch == '\t' )
 984           while( ( err = pIosys->GetError() ) == 0 )
 985         {
 986             if( ch != ' ' && ch != '\t' && ch != '\n' )
 987                 break;
 988             ch = pIosys->Read();
 989         }
 990     }
 991     if( !err )
 992     {
 993         SbxVariableRef pVar = GetTOS();
 994         // Zuerst versuchen, die Variable mit einem numerischen Wert
 995         // zu fuellen, dann mit einem Stringwert
 996         if( !pVar->IsFixed() || pVar->IsNumeric() )
 997         {
 998             USHORT nLen = 0;
 999             if( !pVar->Scan( s, &nLen ) )
1000             {
1001                 err = SbxBase::GetError();
1002                 SbxBase::ResetError();
1003             }
1004             // Der Wert muss komplett eingescant werden
1005             else if( nLen != s.Len() && !pVar->PutString( s ) )
1006             {
1007                 err = SbxBase::GetError();
1008                 SbxBase::ResetError();
1009             }
1010             else if( nLen != s.Len() && pVar->IsNumeric() )
1011             {
1012                 err = SbxBase::GetError();
1013                 SbxBase::ResetError();
1014                 if( !err )
1015                     err = SbERR_CONVERSION;
1016             }
1017         }
1018         else
1019         {
1020             pVar->PutString( s );
1021             err = SbxBase::GetError();
1022             SbxBase::ResetError();
1023         }
1024     }
1025     if( err == SbERR_USER_ABORT )
1026         Error( err );
1027     else if( err )
1028     {
1029         if( pRestart && !pIosys->GetChannel() )
1030         {
1031             BasResId aId( IDS_SBERR_START + 4 );
1032             String aMsg( aId );
1033
1034             //****** DONT CHECK IN, TEST ONLY *******
1035             //****** DONT CHECK IN, TEST ONLY *******
1036             // ErrorBox( NULL, WB_OK, aMsg ).Execute();
1037             //****** DONT CHECK IN, TEST ONLY *******
1038             //****** DONT CHECK IN, TEST ONLY *******
1039
1040             pCode = pRestart;
1041         }
1042         else
1043             Error( err );
1044     }
1045     else
1046     {
1047         // pIosys->ResetChannel();
1048         PopVar();
1049     }
1050 }
1051
1052 // Line Input to Variable. Die Variable ist auf TOS und wird
1053 // anschliessend entfernt.
1054
1055 void SbiRuntime::StepLINPUT()
1056 {
1057     ByteString aInput;
1058     pIosys->Read( aInput );
1059     Error( pIosys->GetError() );
1060     SbxVariableRef p = PopVar();
1061     p->PutString( String( aInput, gsl_getSystemTextEncoding() ) );
1062     // pIosys->ResetChannel();
1063 }
1064
1065 // Programmende
1066
1067 void SbiRuntime::StepSTOP()
1068 {
1069     pInst->Stop();
1070 }
1071
1072 // FOR-Variable initialisieren
1073
1074 void SbiRuntime::StepINITFOR()
1075 {
1076     PushFor();
1077 }
1078
1079 void SbiRuntime::StepINITFOREACH()
1080 {
1081     PushForEach();
1082 }
1083
1084 // FOR-Variable inkrementieren
1085
1086 void SbiRuntime::StepNEXT()
1087 {
1088     if( !pForStk )
1089     {
1090         StarBASIC::FatalError( SbERR_INTERNAL_ERROR );
1091         return;
1092     }
1093     if( pForStk->eForType == FOR_TO )
1094         pForStk->refVar->Compute( SbxPLUS, *pForStk->refInc );
1095 }
1096
1097 // Anfang CASE: TOS in CASE-Stack
1098
1099 void SbiRuntime::StepCASE()
1100 {
1101     if( !refCaseStk.Is() )
1102         refCaseStk = new SbxArray;
1103     SbxVariableRef xVar = PopVar();
1104     refCaseStk->Put( xVar, refCaseStk->Count() );
1105 }
1106
1107 // Ende CASE: Variable freigeben
1108
1109 void SbiRuntime::StepENDCASE()
1110 {
1111     if( !refCaseStk || !refCaseStk->Count() )
1112         StarBASIC::FatalError( SbERR_INTERNAL_ERROR );
1113     else
1114         refCaseStk->Remove( refCaseStk->Count() - 1 );
1115 }
1116
1117 // Standard-Fehlerbehandlung
1118
1119 void SbiRuntime::StepSTDERROR()
1120 {
1121     pError = NULL; bError = TRUE;
1122     pInst->aErrorMsg = String();
1123     pInst->nErr = 0L;
1124     pInst->nErl = 0;
1125     nError = 0L;
1126         SbxErrObject::getUnoErrObject()->Clear();
1127 }
1128
1129 void SbiRuntime::StepNOERROR()
1130 {
1131     pInst->aErrorMsg = String();
1132     pInst->nErr = 0L;
1133     pInst->nErl = 0;
1134     nError = 0L;
1135         SbxErrObject::getUnoErrObject()->Clear();
1136     bError = FALSE;
1137 }
1138
1139 // UP verlassen
1140
1141 void SbiRuntime::StepLEAVE()
1142 {
1143     bRun = FALSE;
1144         // If VBA and we are leaving an ErrorHandler then clear the error ( it's been processed )
1145         if ( bInError && pError )
1146             SbxErrObject::getUnoErrObject()->Clear();
1147 }
1148
1149 void SbiRuntime::StepCHANNEL()          // TOS = Kanalnummer
1150 {
1151     SbxVariableRef pChan = PopVar();
1152     short nChan = pChan->GetInteger();
1153     pIosys->SetChannel( nChan );
1154     Error( pIosys->GetError() );
1155 }
1156
1157 void SbiRuntime::StepCHANNEL0()
1158 {
1159     pIosys->ResetChannel();
1160 }
1161
1162 void SbiRuntime::StepPRINT()            // print TOS
1163 {
1164     SbxVariableRef p = PopVar();
1165     String s1 = p->GetString();
1166     String s;
1167     if( p->GetType() >= SbxINTEGER && p->GetType() <= SbxDOUBLE )
1168         s = ' ';        // ein Blank davor
1169     s += s1;
1170     ByteString aByteStr( s, gsl_getSystemTextEncoding() );
1171     pIosys->Write( aByteStr );
1172     Error( pIosys->GetError() );
1173 }
1174
1175 void SbiRuntime::StepPRINTF()           // print TOS in field
1176 {
1177     SbxVariableRef p = PopVar();
1178     String s1 = p->GetString();
1179     String s;
1180     if( p->GetType() >= SbxINTEGER && p->GetType() <= SbxDOUBLE )
1181         s = ' ';        // ein Blank davor
1182     s += s1;
1183     s.Expand( 14, ' ' );
1184     ByteString aByteStr( s, gsl_getSystemTextEncoding() );
1185     pIosys->Write( aByteStr );
1186     Error( pIosys->GetError() );
1187 }
1188
1189 void SbiRuntime::StepWRITE()            // write TOS
1190 {
1191     SbxVariableRef p = PopVar();
1192     // Muss der String gekapselt werden?
1193     char ch = 0;
1194     switch (p->GetType() )
1195     {
1196         case SbxSTRING: ch = '"'; break;
1197         case SbxCURRENCY:
1198         case SbxBOOL:
1199         case SbxDATE: ch = '#'; break;
1200         default: break;
1201     }
1202     String s;
1203     if( ch )
1204         s += ch;
1205     s += p->GetString();
1206     if( ch )
1207         s += ch;
1208     ByteString aByteStr( s, gsl_getSystemTextEncoding() );
1209     pIosys->Write( aByteStr );
1210     Error( pIosys->GetError() );
1211 }
1212
1213 void SbiRuntime::StepRENAME()           // Rename Tos+1 to Tos
1214 {
1215     SbxVariableRef pTos1 = PopVar();
1216     SbxVariableRef pTos  = PopVar();
1217     String aDest = pTos1->GetString();
1218     String aSource = pTos->GetString();
1219
1220     // <-- UCB
1221     if( hasUno() )
1222     {
1223         implStepRenameUCB( aSource, aDest );
1224     }
1225     else
1226     // --> UCB
1227     {
1228 #ifdef _OLD_FILE_IMPL
1229         DirEntry aSourceDirEntry( aSource );
1230         if( aSourceDirEntry.Exists() )
1231         {
1232             if( aSourceDirEntry.MoveTo( DirEntry(aDest) ) != FSYS_ERR_OK )
1233                 StarBASIC::Error( SbERR_PATH_NOT_FOUND );
1234         }
1235         else
1236                 StarBASIC::Error( SbERR_PATH_NOT_FOUND );
1237 #else
1238         implStepRenameOSL( aSource, aDest );
1239 #endif
1240     }
1241 }
1242
1243 // TOS = Prompt
1244
1245 void SbiRuntime::StepPROMPT()
1246 {
1247     SbxVariableRef p = PopVar();
1248     ByteString aStr( p->GetString(), gsl_getSystemTextEncoding() );
1249     pIosys->SetPrompt( aStr );
1250 }
1251
1252 // Set Restart point
1253
1254 void SbiRuntime::StepRESTART()
1255 {
1256     pRestart = pCode;
1257 }
1258
1259 // Leerer Ausdruck auf Stack fuer fehlenden Parameter
1260
1261 void SbiRuntime::StepEMPTY()
1262 {
1263     // #57915 Die Semantik von StepEMPTY() ist die Repraesentation eines fehlenden
1264     // Arguments. Dies wird in VB durch ein durch den Wert 448 (SbERR_NAMED_NOT_FOUND)
1265     // vom Typ Error repraesentiert. StepEmpty jetzt muesste besser StepMISSING()
1266     // heissen, aber der Name wird der Einfachkeit halber beibehalten.
1267     SbxVariableRef xVar = new SbxVariable( SbxVARIANT );
1268     xVar->PutErr( 448 );
1269     PushVar( xVar );
1270     // ALT: PushVar( new SbxVariable( SbxEMPTY ) );
1271 }
1272
1273 // TOS = Fehlercode
1274
1275 void SbiRuntime::StepERROR()
1276 {
1277     SbxVariableRef refCode = PopVar();
1278     USHORT n = refCode->GetUShort();
1279     SbError error = StarBASIC::GetSfxFromVBError( n );
1280         pInst->Error( error );
1281 }
1282