/* * $Id$ */ /* * Harbour Project source code: * Get Class * * Copyright 1999 Ignacio Ortiz de ZŁniga * www - http://www.harbour-project.org * * 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, with one exception: * * The exception is that if you link the Harbour Runtime Library (HRL) * and/or the Harbour Virtual Machine (HVM) with other files to produce * an executable, this does not by itself cause the resulting executable * to be covered by the GNU General Public License. Your use of that * executable is in no way restricted on account of linking the HRL * and/or HVM code into it. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit * their web site at http://www.gnu.org/). * */ #include "hbclass.ch" #include "color.ch" #include "common.ch" #include "setcurs.ch" /* TODO: Scrolling buffer support. */ /* TOFIX: Handling of date. */ /* TODO: Missing methods. */ /* TOFIX: WordLeft(), WordRight() methods */ #define GET_CLR_UNSELECTED 0 #define GET_CLR_ENHANCED 1 //----------------------------------------------------------------------------// CLASS TGet // Exported DATA BadDate DATA Block DATA Buffer DATA Cargo DATA Changed DATA Clear DATA Col DATA ColorSpec DATA DecPos DATA ExitState DATA HasFocus DATA Minus DATA Name DATA Original DATA Picture DATA Pos DATA PostBlock DATA PreBlock DATA Reader DATA Rejected DATA Row DATA SubScript DATA Type DATA TypeOut METHOD New( nRow, nCol, bVarBlock, cVarName, cPicture, cColorSpec ) METHOD Assign() INLINE ::VarPut( ::unTransform() ) METHOD Display() METHOD ColorDisp( cColorSpec ) INLINE ::ColorSpec := cColorSpec, ::Display() METHOD KillFocus() METHOD Reset() METHOD SetFocus() METHOD Undo() METHOD UnTransform() METHOD UpdateBuffer() INLINE ::Assign() METHOD VarGet() METHOD VarPut() METHOD End() METHOD Home() MESSAGE Left() METHOD _Left() MESSAGE Right() METHOD _Right() METHOD ToDecPos() METHOD WordLeft() METHOD WordRight() METHOD BackSpace() MESSAGE Delete() METHOD _Delete() METHOD DelEnd() METHOD DelLeft() METHOD DelRight() METHOD DelWordLeft() METHOD DelWordRight() METHOD Insert( cChar ) METHOD OverStrike( cChar ) // Protected DATA cPicMask, cPicFunc, nMaxLen, lEdit, lDecRev, lPicComplex METHOD DeleteAll() METHOD IsEditable( nPos ) METHOD Input( cChar ) METHOD PutMask( cBuffer, lEdit ) ENDCLASS //---------------------------------------------------------------------------// METHOD New( nRow, nCol, bVarBlock, cVarName, cPicture, cColorSpec ) CLASS TGet local cChar local nAt local nFor local cNum DEFAULT nRow TO Row() DEFAULT nCol TO Col() DEFAULT cVarName TO "" DEFAULT cPicture TO "" DEFAULT cColorSpec TO hb_ColorIndex( SetColor(), CLR_UNSELECTED ) + "," + hb_ColorIndex( SetColor(), CLR_ENHANCED ) ::BadDate := .f. ::Block := bVarBlock ::Changed := .f. ::Clear := .f. ::Col := nCol ::ColorSpec := cColorSpec ::DecPos := Nil ::ExitState := 0 ::HasFocus := .f. ::Minus := .f. ::Name := cVarName ::Original := ::VarGet() ::Picture := cPicture ::Pos := Nil ::PostBlock := Nil ::PreBlock := Nil ::Reader := Nil ::Rejected := .f. ::Row := nRow ::SubScript := Nil ::Type := Valtype( ::Original ) ::TypeOut := .f. // Existe function en picture if Left( cPicture, 1 ) == "@" nAt := At( " ", cPicture ) if nAt == 0 ::cPicFunc := cPicture ::cPicMask := "" else ::cPicFunc := SubStr( cPicture, 1, nAt - 1 ) ::cPicMask := SubStr( cPicture, nAt + 1 ) endif if ( nAt := At( "S", ::cPicFunc ) ) > 0 for nFor := nAt + 1 to Len( ::cPicFunc ) if !IsDigit( SubStr( ::cPicFunc, nFor, 1 ) ) exit endif next ::cPicFunc := SubStr( ::cPicFunc, 1, nAt - 1 ) + SubStr( ::cPicFunc, nFor ) if ::cPicFunc == "@" ::cPicFunc := "" endif endif else ::cPicFunc := "" ::cPicMask := cPicture endif // Comprobar si tiene la , y el . cambiado (Solo en Xbase++) ::lDecRev := "," $ Transform( 1.1, "9.9" ) // Generate default picture mask if not specified if Empty( ::cPicMask ) do case case ::type == "D" ::cPicMask := Set( _SET_DATEFORMAT ) ::cPicMask := StrTran( ::cPicmask, "y", "9" ) ::cPicMask := StrTran( ::cPicmask, "m", "9" ) ::cPicMask := StrTran( ::cPicmask, "d", "9" ) case ::type == "N" cNum := Str( ::Original ) if ( nAt := At( iif( ::lDecRev, ",", "." ), cNum ) ) > 0 ::cPicMask := Replicate( '9', nAt - 1 ) + iif( ::lDecRev, ",", "." ) ::cPicMask += Replicate( '9', Len( cNum ) - Len( ::cPicMask ) ) else ::cPicMask := Replicate( '9', Len( cNum ) ) endif endcase endif // Comprobar si tiene caracteres embebidos no modificables en la plantilla ::lPicComplex := .f. if !Empty( ::cPicMask ) For nFor := 1 to Len( ::cPicMask ) cChar := SubStr( ::cPicMask, nFor, 1 ) if !cChar $ "!ANX9#" ::lPicComplex := .t. exit endif Next endif ::buffer := ::PutMask( ::Original, .f. ) return Self //---------------------------------------------------------------------------// METHOD Display() CLASS TGet local nOldCursor := SetCursor( SC_NONE ) DispOutAt( ::Row, ::Col,; ::buffer, hb_ColorIndex( ::ColorSpec, iif( ::HasFocus, GET_CLR_ENHANCED, GET_CLR_UNSELECTED ) ) ) SetCursor( nOldCursor ) return Self //---------------------------------------------------------------------------// METHOD End() CLASS TGet local nLastCharPos if ::HasFocus nLastCharPos := Min( Len( RTrim( ::buffer ) ) + 1, ::nMaxLen ) if ::Pos != nLastCharPos ::Pos := nLastCharPos else ::Pos := ::nMaxLen endif ::Clear := .f. SetPos( ::Row, ::Col + ::Pos - 1 ) endif return nil //---------------------------------------------------------------------------// METHOD Home() CLASS TGet if ::HasFocus ::Pos := 1 ::Clear := .f. SetPos( ::Row, ::Col + ::Pos - 1 ) endif return nil //---------------------------------------------------------------------------// METHOD Reset() CLASS TGet if ::hasfocus ::buffer := ::PutMask( ::VarGet() ) ::pos := 1 endif return Self //---------------------------------------------------------------------------// METHOD Undo() CLASS TGet if ::hasfocus ::buffer := ::PutMask( ::original ) ::pos := 1 endif return Self //---------------------------------------------------------------------------// METHOD SetFocus() CLASS TGet ::hasfocus := .t. ::rejected := .f. ::typeout := .f. ::buffer := ::PutMask( ::VarGet(), .f. ) ::changed := .f. ::clear := ( "K" $ ::cPicFunc .or. ::type == "N") ::nMaxLen := Len( ::buffer ) ::pos := 1 ::lEdit := .f. if ::type == "N" ::decpos := At( iif( ::lDecRev, ",", "." ), ::buffer ) ::minus := ( "-" $ ::buffer .or. "(" $ ::buffer ) else ::decpos := Nil ::minus := .f. endif if ::type == "D" ::BadDate := ( At( " ", DToC( CToD( ::buffer ) ) ) != 0 ) else ::BadDate := .f. endif ::Display() SetPos( ::Row, ::Col + ::Pos - 1 ) return Self //---------------------------------------------------------------------------// METHOD KillFocus() CLASS TGet ::hasfocus := .f. ::pos := Nil ::Assign() ::Display() ::buffer := ::PutMask() return Self //---------------------------------------------------------------------------// METHOD VarPut( xValue ) CLASS TGet Eval( ::block, xValue ) return xValue //---------------------------------------------------------------------------// METHOD VarGet() CLASS TGet return Eval( ::block ) //---------------------------------------------------------------------------// METHOD Untransform( cBuffer ) CLASS TGet local xValue local cChar local nFor DEFAULT cBuffer TO ::buffer do case case ::type == "C" if "R" $ ::cPicFunc for nFor := 1 to Len( ::cPicMask ) cChar := SubStr( ::cPicMask, nFor, 1 ) if !cChar $ "ANX9#!" cBuffer := SubStr( cBuffer, 1, nFor - 1 ) + Chr( 1 ) + SubStr( cBuffer, nFor + 1 ) endif next cBuffer := StrTran( cBuffer, Chr( 1 ), "" ) endif xValue := cBuffer case ::type == "N" if "E" $ ::cPicFunc .or. ::lDecRev cBuffer := StrTran( cBuffer, ".", "" ) cBuffer := StrTran( cBuffer, ",", "." ) else cBuffer := StrTran( cBuffer, ",", "" ) endif cBuffer := StrTran( cBuffer, "$", "" ) cBuffer := StrTran( cBuffer, "*", "" ) cBuffer := StrTran( cBuffer, "-", "" ) cBuffer := StrTran( cBuffer, "(", "" ) cBuffer := StrTran( cBuffer, ")", "" ) cBuffer := Alltrim( cBuffer ) xValue := Val( cBuffer ) if ::minus xValue := -xValue endif case ::type == "L" cBuffer := Upper( cBuffer ) xValue := "T" $ cBuffer .or. "Y" $ cBuffer case ::type == "D" if "E" $ ::cPicFunc cBuffer := SubStr( cBuffer, 4, 3 ) + SubStr( cBuffer, 1, 3 ) + SubStr( cBuffer, 8 ) endif xValue := CToD( cBuffer ) endcase return xValue //---------------------------------------------------------------------------// METHOD overstrike( cChar ) CLASS TGet if ::type == "N" .and. !::lEdit ::pos := 1 endif if ::Clear .and. ::pos == 1 ::DeleteAll() ::Clear := .f. ::lEdit := .f. endif if !::lEdit ::buffer := ::PutMask( ::VarGet(), .t. ) ::lEdit := .t. do while !::IsEditable( ::pos ) .and. ::pos <= ::nMaxLen ::pos++ enddo if ::pos > ::nMaxLen ::pos := 1 endif endif cChar := ::Input( cChar ) if cChar == "" ::Rejected := .t. return Self endif ::buffer := SubStr( ::buffer, 1, ::Pos - 1 ) + cChar + SubStr( ::buffer, ::Pos + 1 ) ::Changed := ( ::unTransform() != ::Original ) ::Assign() ::Right() if ::type == "D" ::BadDate := ( At(" ", DToC( CToD( ::buffer ) ) ) != 0 ) else ::BadDate := .f. endif ::Display() SetPos( ::Row, ::Col + iif( ::Pos != nil, ::Pos - 1, 0 ) ) return Self //---------------------------------------------------------------------------// METHOD Insert( cChar ) CLASS TGet if ::type == "N" .and. !::lEdit ::pos := 1 endif if ::Clear .and. ::pos == 1 ::DeleteAll() ::Clear := .f. ::lEdit := .f. endif if !::lEdit ::buffer := ::PutMask( ::VarGet(), .t. ) ::lEdit := .t. endif cChar := ::Input(cChar) if cChar == "" ::Rejected := .t. return Self endif ::buffer := Left( SubStr( ::buffer, 1, ::Pos - 1 ) + cChar + SubStr( ::buffer, ::Pos ), ::nMaxLen ) ::Changed := ( ::unTransform() != ::Original ) ::Assign() ::Right() if ::type == "D" ::BadDate := ( At( " ", DToC( CToD( ::buffer ) ) ) != 0 ) else ::BadDate := .f. endif ::Display() // Kwon,Oh-Chul SetPos( ::Row, ::Col + iif( ::Pos != nil, ::Pos - 1, 0 ) ) return Self //---------------------------------------------------------------------------// METHOD _Right() CLASS TGet local nPos if !::hasfocus return Self endif ::TypeOut := .f. ::Clear := .f. if ::pos == ::nMaxLen ::TypeOut := .t. return Self endif nPos := ::Pos + 1 do while !::IsEditable( nPos ) .and. nPos <= ::nMaxLen nPos++ Enddo if nPos <= ::nMaxLen ::Pos := nPos else ::TypeOut := .t. endif SetPos( ::Row, ::Col + ::Pos - 1 ) return Self //---------------------------------------------------------------------------// METHOD _Left() CLASS TGet local nPos if !::hasfocus return Self endif ::TypeOut := .f. ::Clear := .f. if ::pos == 1 ::TypeOut := .t. return Self endif nPos := ::Pos - 1 do while !::IsEditable( nPos ) .and. nPos > 0 nPos-- Enddo if nPos > 0 ::Pos := nPos else ::TypeOut := .t. endif SetPos( ::Row, ::Col + ::Pos - 1 ) return Self //---------------------------------------------------------------------------// METHOD WordLeft() CLASS TGet local nPos if !::hasfocus return Self endif ::TypeOut := .f. ::Clear := .f. if ::pos == 1 ::TypeOut := .t. return Self endif nPos := ::Pos - 1 do while SubStr( ::buffer, nPos, 1 ) != " " .and. nPos > 0 nPos-- Enddo if nPos > 0 ::Pos := nPos endif SetPos( ::Row, ::Col + ::Pos - 1 ) return Self //---------------------------------------------------------------------------// METHOD WordRight() CLASS TGet local nPos if !::hasfocus return Self endif ::TypeOut := .f. ::Clear := .f. if ::pos == ::nMaxLen ::TypeOut := .t. return Self endif nPos := ::Pos + 1 do while SubStr( ::buffer, nPos, 1 ) != " " .and. nPos <= ::nMaxLen nPos++ Enddo if nPos <= ::nMaxLen ::Pos := nPos endif SetPos( ::Row, ::Col + ::Pos - 1 ) return Self //---------------------------------------------------------------------------// METHOD ToDecPos() CLASS TGet if !::HasFocus .or. ::DecPos == Nil Return .f. endif ::Clear := .f. ::buffer := ::PutMask( ::UnTransform(), .t. ) ::pos := ::DecPos + 1 ::Display() SetPos( ::Row, ::Col + ::Pos - 1 ) return .t. //---------------------------------------------------------------------------// METHOD IsEditable( nPos ) CLASS TGet local cChar if Empty( ::cPicMask ) return .t. endif if nPos > ::nMaxLen return .f. endif cChar := SubStr( ::cPicMask, nPos, 1 ) do case case ::type == "C" return cChar $ "!ANX9#" case ::type == "N" return cChar $ "9#$*" case ::type == "D" return cChar == "9" case ::type == "L" return cChar $ "TFYN" endcase return .f. //---------------------------------------------------------------------------// METHOD Input( cChar ) CLASS TGet do case case ::type == "N" do case case cChar == "-" if ::pos != 1 return "" endif ::minus := .t. case cChar == "." ::toDecPos() return "" case !( cChar $ "0123456789" ) return "" endcase case ::type == "D" if !( cChar $ "0123456789" ) return "" endif case ::type == "L" if !( Upper( cChar ) $ "YNTF" ) return "" endif endcase if !Empty( ::cPicFunc ) cChar := Transform( cChar, ::cPicFunc ) endif if !Empty( ::cPicMask ) cChar := Transform( cChar, SubStr( ::cPicMask, ::pos, 1 ) ) endif return cChar //---------------------------------------------------------------------------// METHOD PutMask( xValue, lEdit ) CLASS TGet local cChar local cBuffer local nFor local nLen local nAt DEFAULT xValue TO ::VarGet() DEFAULT lEdit TO ::HasFocus cBuffer := Transform( xValue, Alltrim( ::cPicFunc + " " + ::cPicMask ) ) if lEdit .and. ::type == "N" .and. !Empty( ::cPicMask ) nLen := Len( cBuffer ) for nFor := 1 to nLen cChar := SubStr( ::cPicMask, nFor, 1 ) if cChar $ ",." .and. SubStr( cBuffer, nFor, 1 ) != cChar cBuffer := SubStr( cBuffer, 1, nFor - 1 ) + cChar + SubStr( cBuffer, nFor + 1 ) endif next if ( nAt := At( " ", cBuffer ) ) > 0 cBuffer := StrTran( cBuffer, "0", " ", nAt ) endif if ::lDecRev cBuffer := StrTran( cBuffer, ",", Chr( 1 ) ) cBuffer := StrTran( cBuffer, ".", "," ) cBuffer := StrTran( cBuffer, Chr( 1 ), "." ) endif endif return cBuffer //---------------------------------------------------------------------------// METHOD BackSpace() CLASS TGet local nPos := ::Pos ::Left() if ::Pos < nPos ::Delete() endif return Self //---------------------------------------------------------------------------// METHOD _Delete() CLASS TGet do case case ::type == "C" if !::lPicComplex ::buffer := Padr( SubStr( ::buffer, 1, ::Pos - 1 ) + ; SubStr( ::buffer, ::Pos + 1 ), ::nMaxLen ) else ::buffer := SubStr( ::buffer, 1, ::Pos - 1 ) + " " + ; SubStr( ::buffer, ::Pos + 1 ) endif case ::type == "N" if SubStr( ::buffer, ::Pos, 1 ) == "-" ::minus := .f. endif ::buffer := SubStr( ::buffer, 1, ::Pos - 1 ) + " " + ; SubStr( ::buffer, ::Pos + 1 ) case ::type == "D" ::buffer := SubStr( ::buffer, 1, ::Pos - 1 ) + " " + ; SubStr( ::buffer, ::Pos + 1 ) case ::type == "L" ::buffer := " " endcase ::Assign() ::Display() SetPos( ::Row, ::Col + iif( ::Pos != nil, ::Pos - 1, 0 ) ) return Self //---------------------------------------------------------------------------// METHOD DeleteAll() CLASS TGet local xValue do case case ::type == "C" xValue := Space( ::nMaxlen ) case ::type == "N" xValue := 0 case ::type == "D" xValue := DToC( "" ) case ::type == "L" xValue := .f. endcase ::buffer := ::PutMask( xValue, .t. ) ::Pos := 1 ::Assign() return Self //---------------------------------------------------------------------------// METHOD DelEnd() CLASS TGet /* TODO: Implement DelEnd() */ return Self METHOD DelLeft() CLASS TGet /* TODO: Implement DelLeft() */ return Self METHOD DelRight() CLASS TGet /* TODO: Implement DelRight() */ return Self METHOD DelWordLeft() CLASS TGet /* TODO: Implement DelWordLeft() */ return Self METHOD DelWordRight() CLASS TGet /* TODO: Implement DelWordRight() */ return Self //---------------------------------------------------------------------------// Function GetNew( nRow, nCol, bVarBlock, cVarName, cPicture, cColor ) return TGet():New( nRow, nCol, bVarBlock, cVarName, cPicture, cColor ) //---------------------------------------------------------------------------// function __GET( uVar, cVarName, cPicture, bValid, bWhen, bSetGet ) return _GET_( uVar, cVarName, cPicture, bValid, bWhen, bSetGet ) function _GET_( uVar, cVarName, cPicture, bValid, bWhen, bSetGet ) local oGet := TGet():New(,, bSetGet, cVarName, cPicture ) uVar := uVar // Suppress unused variable warning oGet:PreBlock := bWhen oGet:PostBlock := bValid return oGet //---------------------------------------------------------------------------//