fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
aed2388134151a9d7dfd83fa874f13d64ec00c71
harbour-core/harbour/contrib/hbgd/tests/test_out.prg
Viktor Szakats 62a09afd19 2009-10-19 23:13 UTC+0200 Viktor Szakats (harbour.01 syenar.hu) 
* contrib/gtalleg/tests/hbmk.hbm
  * contrib/hbmysql/utils/hbmk.hbm
  * contrib/hbmysql/utils/dbf2mysq.prg
  * contrib/hbmysql/tests/test.prg
  * contrib/hbmysql/tests/hbmk.hbm
  * contrib/hbct/tests/tab.prg
  * contrib/hbct/tests/tokensep.prg
  * contrib/hbct/tests/datetime.prg
  * contrib/hbct/tests/hbmk.hbm
  * contrib/hbct/tests/token2.prg
  * contrib/hbct/tests/charhist.prg
  * contrib/xhb/tests/hbmk.hbm
  * contrib/hbodbc/tests/hbmk.hbm
  * contrib/hbtpathy/tests/hbmk.hbm
  * contrib/hbmzip/tests/hbmk.hbm
  * contrib/hbsqlit3/tests/hbmk.hbm
  * contrib/hbsqlit3/tests/authoriz.prg
  * contrib/hbblat/tests/hbmk.hbm
  * contrib/hbqt/tests/hbmk.hbm
  * contrib/hbfbird/tests/simple.prg
  * contrib/hbfbird/tests/test.prg
  * contrib/hbfbird/tests/hbmk.hbm
  * contrib/hbziparc/tests/hbmk.hbm
  * contrib/hbxbp/tests/hbmk.hbm
  * contrib/hbnf/tests/ftgete.prg
  * contrib/hbnf/tests/hbmk.hbm
  * contrib/hbcurl/tests/ftp_uldl.prg
  * contrib/hbcurl/tests/hbmk.hbm
  * contrib/hbmemio/tests/hbmk.hbm
  * contrib/gtqtc/tests/demoqtc.prg
  * contrib/gtqtc/tests/hbmk.hbm
  * contrib/hbnetio/utils/hbmk.hbm
  * contrib/hbnetio/tests/hbmk.hbm
  * contrib/rddsql/tests/hbmk.hbm
  * contrib/hbhpdf/tests/harupdf.prg
  * contrib/hbhpdf/tests/hbmk.hbm
  * contrib/rddado/tests/hbmk.hbm
  * contrib/gtwvg/tests/hbmk.hbm
  * contrib/hbpgsql/tests/async.prg
  * contrib/hbpgsql/tests/test.prg
  * contrib/hbpgsql/tests/hbmk.hbm
  * contrib/hbpgsql/tests/cache.prg
  * contrib/hbpgsql/tests/stress.prg
  * contrib/hbpgsql/tests/dbf2pg.prg
  * contrib/hbclipsm/tests/hbmk.hbm
  * contrib/rddads/tests/datad.prg
  * contrib/rddads/tests/hbmk.hbm
  * contrib/rddads/tests/testmg.prg
  * contrib/hbfimage/tests/fitest.prg
  * contrib/hbfimage/tests/hbmk.hbm
  * contrib/hbgd/tests/tostring.prg
  * contrib/hbgd/tests/gdtestcl.prg
  * contrib/hbgd/tests/gdtest.prg
  * contrib/hbgd/tests/animgif.prg
  * contrib/hbgd/tests/testdpi.prg
  * contrib/hbgd/tests/hbmk.hbm
  * contrib/hbgd/tests/counter.prg
  * contrib/hbgd/tests/antialia.prg
  * contrib/hbgd/tests/bartest.prg
  * contrib/hbgd/tests/barms.prg
  * contrib/hbgd/tests/test_out.prg
  * contrib/hbmisc/tests/testhbf.prg
  * contrib/hbmisc/tests/hbmk.hbm
  * contrib/hbmisc/tests/twirl.prg
  * contrib/hbtip/tests/dnldftp.prg
  * contrib/hbtip/tests/upld_ftp.prg
  * contrib/hbtip/tests/dbtohtml.prg
  * contrib/hbtip/tests/hbmk.hbm
  * contrib/hbwin/hbwin.h
  * contrib/hbwin/hbwin.ch
  * contrib/hbwin/tests/testsim.prg
  * contrib/hbwin/tests/testole.prg
  * contrib/hbwin/tests/testcom2.prg
  * contrib/hbwin/win_com.c
  * contrib/hbssl/tests/hbmk.hbm
  * contrib/hbbtree/tests/hbmk.hbm
    ! Fixed warnings and errors in test apps.
    + Added -es2 option to test/util default options.
    * Renamed few macros in hbwin / win_com implementation:
        FCN* -> WIN_COM_FUN_*
        WPDBG* -> WIN_COM_DBG_*
    ; TOFIX: Some errors are left in hbgd/test_out.prg and 
             gtwvg to be fixed, now the can't be built.
             Please do it.
2009-10-19 21:17:04 +00:00

346 lines
8.2 KiB
Plaintext
Raw Blame History

/*
* $Id$
*/
/*
* Copyright 2004-2005 Francesco Saverio Giudice <info@fsgiudice.com>
*
* Windows CGI test application
*/
#include "gd.ch"
#include "common.ch"
#command WRITE <c> => FWrite( 1, <c> + CHR(13)+CHR(10) )
#command OutHTML <c> => WRITE <c>
PROCEDURE Main(...)
LOCAL cPar
LOCAL aParams := hb_aParams()
LOCAL cQuery := GetEnv( "QUERY_STRING" )
LOCAL hParams := hb_Hash()
LOCAL cText, cImg, nPt, nWidth, nHeight, cPhoto
IF Empty( aParams )
IF !Empty( cQuery )
hParams := GetVars( cQuery )
ENDIF
ELSE
hParams := GetParams( aParams )
ENDIF
//-----------------------------------------------------------------------------------------
// Gestione parametri
IF !Empty( hParams )
FOR EACH cPar IN hParams:Keys
do case
case cPar == "txt"
cText := hb_hGet( hParams, cPar )
case cPar == "img"
cImg := hb_hGet( hParams, cPar )
case cPar == "photo"
cPhoto := hb_hGet( hParams, cPar )
case cPar == "width"
nWidth := Val( hb_hGet( hParams, cPar ) )
case cPar == "height"
nHeight := Val( hb_hGet( hParams, cPar ) )
case cPar == "pt"
nPt := Val( hb_hGet( hParams, cPar ) )
endcase
NEXT
ENDIF
//__OutDebug( cQuery, ValToPrg( hParams ) )
//-----------------------------------------------------------------------------------------
//DEFAULT cText TO "Testo di Prova"
DEFAULT nPt TO 30
IF cImg != NIL
//OutJpg( cImg, nPt )
OutPhoto( cImg, nWidth, nHeight )
ELSEIF cPhoto != NIL
StartHTML()
//OutHTML ValToPrg( hParams ) + "<br>"
//OutHTML ValToPrg( cParams ) + "<br>"
//OutHTML ValToPrg( cQuery ) + "<br>"
//OutHTML "<img src='test_out.exe?img=" + cPhoto + "&width=" + AllTrim( Str( nWidth ) ) + "&height=" + AllTrim( Str( nHeight ) ) + "'>" + "<br>"
OutHTML "<table border=1>"
OutHTML "<tr><td align='center'>"
OutHTML "<img src='test_out.exe?img=" + cPhoto + "'>" + "<br>"
OutHTML "</td></tr>"
OutHTML "<tr><td align='center'>"
OutHTML "<img src='test_out.exe?img=" + cPhoto + ;
IIF( nWidth != NIL , "&width=" + AllTrim( Str( nWidth ) ) , "" ) + ;
IIF( nHeight != NIL, "&height=" + AllTrim( Str( nHeight ) ), "" ) + ;
"'>" + "<br>"
OutHTML "</td></tr>"
OutHTML "<tr><td align='center'>"
OutHTML cPhoto
OutHTML "</td></tr>"
OutHTML "</table>"
OutHTML "<br>"
//OutHTML "<img src='test_out.exe?img=" + cText + "_2&pt=" + AllTrim( Str( nPt ) ) + "'>" + "<br>"
//OutHTML OS() + "<br>"
//OutHTML IIF( OS_ISWINNT(), "WIN NT", "NON WIN NT" ) + "<br>"
EndHTML()
ELSE
StartHTML()
EndHTML()
ENDIF
RETURN
PROCEDURE StartHTML( cTitle )
DEFAULT cTitle TO ""
WRITE 'content-type: text/html'
WRITE 'Pragma: no-cache'
WRITE CHR(13)+CHR(10)
WRITE "<html>"
WRITE "<head>"
WRITE "<title>" + cTitle + "</title>"
WRITE "</head>"
WRITE "<body>"
RETURN
PROCEDURE EndHTML( cTitle )
WRITE "</body>"
WRITE "</html>"
RETURN
// per windows: SET GDFONTPATH=C:\windows\fonts
// per linux : export GDFONTPATH=/usr/share/fonts/default/TrueType
PROCEDURE OutPhoto( cPhoto, nWidth, nHeight )
LOCAL cType
LOCAL oImage := GDImage():LoadFromFile( cPhoto )
IF nWidth != NIL .AND. nHeight != NIL
oImage:Resize( nWidth, nHeight )
ELSEIF nWidth != NIL .AND. nHeight == NIL
nHeight := oImage:Height() * ( nWidth / oImage:Width() )
oImage:Resize( nWidth, nHeight )
ELSEIF nWidth == NIL .AND. nHeight != NIL
nWidth := oImage:Width() * ( nHeight / oImage:Height() )
oImage:Resize( nWidth, nHeight )
ENDIF
//__OutDebug( hb_dumpvar( oImage ) )
WRITE 'content-type: ' + oImage:cMime + CHR(13)+CHR(10)
cType := oImage:cType
DO CASE
CASE cType == "jpeg"
oImage:OutputJpeg()
CASE cType == "gif"
oImage:OutputGif()
CASE cType == "png"
oImage:OutputPng()
ENDCASE
oImage := NIL
RETURN
PROCEDURE OutJpg( cText, nPitch )
LOCAL cOS := OS()
LOCAL cPath := IIF( Left( cOS, 10 ) == "Windows NT", "C:\winnt\fonts\", "C:\windows\fonts\" )
LOCAL oI, cyan, blue
LOCAL aSize, nWidth, nHeight, nX, nY
LOCAL cFont := cPath + "verdana.ttf"
DEFAULT cText TO "Sample TEXT"
DEFAULT nPitch TO 30
/* Create an image in memory */
oI := GDImage( 400, 100 )
/* Allocate background */
cyan := oI:SetColor(0, 255, 255)
/* Allocate drawing color */
blue := oI:SetColor(0, 0, 200)
//oI:SetTransparent( blue )
oI:SetFontName( cFont )
oI:SetFontPitch( nPitch )
//__OutDebug( oI:GetFTFontHeight() )
aSize := oI:GetFTStringSize( cText )
nWidth := aSize[1]
nHeight := aSize[2]
nX := aSize[3]
nY := aSize[4]
oI:Resize( nWidth, nHeight )
/* Allocate drawing color */
blue := oI:SetColor(0, 0, 200)
oI:SetFontName( cPath + "verdana.ttf" )
oI:SetFontPitch( nPitch )
oI:SayFreeType( 0 - nX, 0 + nHeight - nY, cText, , , 0, blue )
//oI:SayFreeType( 0, 0, cText, , , 0, blue )
//oI:Resize( nWidth, nHeight )
//__OutDebug( "prima", oI:Width(), oI:Height() )
//oI:Resize( 60, 40 )
//__OutDebug( "dopo", oI:Width(), oI:Height() )
//oI:SetFontLarge()
//oI:SetColor( blue )
//oI:Say( 0, 0, cText )
WRITE 'content-type: image/jpeg' + CHR(13)+CHR(10)
oI:OutputJpeg()
RETURN
FUNCTION GetVars( cFields, cSeparator )
LOCAL hHashVars := hb_Hash()
LOCAL aField, cField, aFields
LOCAL cName, xValue
DEFAULT cSeparator TO "&"
aFields := HB_RegExSplit( cSeparator, cFields )
FOR EACH cField in aFields
aField := HB_RegexSplit( "=", cField, 2 )
IF Len( aField ) != 2
LOOP
ENDIF
cName := LTrim( aField[1] )
xValue := UrlDecode( aField[2] )
// Tracelog( "cName, xValue", cName, xValue )
// is it an array entry?
IF Substr( cName, Len( cName ) - 1 ) == "[]"
cName := Substr( cName, 1, Len( cName ) - 2 )
hHashVars[ cName ] := { xValue }
ELSE
hHashVars[ cName ] := xValue
ENDIF
//Tracelog( "hHashVars, cName, xValue", DumpValue( hHashVars ), cName, xValue )
NEXT
//__OutDebug( hHashVars )
RETURN hHashVars
FUNCTION GetParams( aParams )
LOCAL hHashVars := hb_Hash()
LOCAL aField, cField, aFields
LOCAL cName, xValue
aFields := aParams
FOR EACH cField in aFields
aField := HB_RegexSplit( "=", cField, 2 )
IF Len( aField ) != 2
LOOP
ENDIF
cName := LTrim( aField[1] )
xValue := UrlDecode( aField[2] )
// Tracelog( "cName, xValue", cName, xValue )
// is it an array entry?
IF Substr( cName, Len( cName ) - 1 ) == "[]"
cName := Substr( cName, 1, Len( cName ) - 2 )
hHashVars[ cName ] := { xValue }
ELSE
hHashVars[ cName ] := xValue
ENDIF
//Tracelog( "hHashVars, cName, xValue", DumpValue( hHashVars ), cName, xValue )
NEXT
//__OutDebug( hHashVars )
RETURN hHashVars
************************************************************
* Decoding URL
* Can return both a string or a number
*
FUNCTION URLDecode( cStr )
LOCAL cRet := "", i, cCar
LOCAL lNumeric := .T.
FOR i := 1 TO Len( cStr )
cCar := cStr[i]
DO CASE
CASE cCar == "+"
cRet += " "
CASE cCar == "%"
i ++
cRet += Chr( hb_HexToNum( SubStr( cStr, i, 2 ) ) )
i ++
OTHERWISE
cRet += cCar
ENDCASE
IF (cRet[i] > "9" .or. cRet[i] < "0") .and. cRet[i] != "."
lNumeric := .F.
ENDIF
NEXT
*IF lNumeric
* cRet := Val( cRet )
*ENDIF
RETURN cRet
FUNCTION URLEncode( cStr )
LOCAL cRet := "", i, nVal, cCar
FOR i := 1 TO Len( cStr )
cCar := cStr[i]
DO CASE
CASE cCar == " "
cRet += "+"
CASE cCar >= "A" .and. cCar <= "Z"
cRet += cCar
CASE cCar >= "a" .and. cCar <= "z"
cRet += cCar
CASE cCar >= "0" .and. cCar <= "9"
cRet += cCar
OTHERWISE
nVal := Asc( cCar )
cRet += "%" + hb_NumToHex( nVal )
ENDCASE
NEXT
RETURN cRet
Reference in New Issue View Git Blame Copy Permalink