unit WdbChart;	{TWdbChartFX web action for use with WebHub}
(*
Copyright (c) 1995-1997 HREF Tools Corp. 

Permission is hereby granted, on 4-Jun-1997, free of charge, to any person 
obtaining a copy of this software (the "Software"), to deal in the Software 
without restriction, including without limitation the rights to use, copy, 
modify, merge, publish, distribute, sublicense, and/or sell copies of the 
Software, and to permit persons to whom the Software is furnished to do so, 
subject to the following conditions:

The above copyright notice and this permission notice shall be included in 
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 
THE SOFTWARE.

*)

interface

uses
  Classes, Dialogs, Forms, SysUtils, Messages, StdCtrls
, Windows
, OleCtrls, ChartFX
, Graphics, DB, dbTables
, ucString
, WebLink
, CgiServ  
, HtmlSend 
, GifBmp32
;

type
  TIMGType = (imgGIF,imgBMP,imgPNG);

type
  TWdbChartFX = class(TWebAction)
  private
    { Private declarations -- custom for this component }
    fDataSource : TDataSource;
    fFieldDisplayList : tStringList;
    fChartFX : TChartFX;
    fCaption : string;
    fLabelXAxis : boolean;
    fMaxPoints : integer;
    fServerBasePath : string;
    fRelativePath : string;
    fFieldIndexList : array [0..255] of integer;
    fNFields : integer;     { compatible with FieldCount type }
    fUseFieldDisplayList : boolean;
    function getTmpFilename(TargetDir : string) : string;
    function MakeGIFStream: TMemoryStream;
    procedure setFieldDisplayList(Value : tStringList);
    function getFileSize( filename : string ) : longint;

  protected
    procedure DoExecute; override;
    function  DoUpdate: Boolean; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;

    function DrawChart : boolean;
    function MakeIMGFile(IMGType : TIMGType) : string;
    function SendChartIMG(IMGType : TImgType) : Boolean;

  published
    property DataSource : TDataSource read fDataSource write fDataSource;
    property ChartFX : TChartFX read fChartFX write fChartFX;
    property Caption : string read fCaption write fCaption;
    property FieldDisplayList : tStringList read fFieldDisplayList write setFieldDisplayList;
    property UseFieldDisplayList : boolean read fUseFieldDisplayList write fUseFieldDisplayList;
    property LabelXAxis : boolean read fLabelXAxis write fLabelXAxis;
    property RelativePath : string read fRelativePath write fRelativePath;
    property MaxPoints : integer read fMaxPoints write fMaxPoints;
    { e.g. c:\website\htdocs\ }
    property  ServerBasePath : string read fServerBasePath write fServerBasePath;

end;


const
  MAXTABLEFIELDS = 255;  { no more than 255 fields displayed in HTML Table }

//procedure Register;

implementation

{---------------------------------------------------------------}

function TWdbChartFX.DoUpdate:Boolean;
var
  a1:string;
begin
  Result:=inherited DoUpdate;
  if not result then
    exit;

  a1:='';
  if fChartFX = nil then
    a1:='Missing ChartFX property'
  else
  if fDataSource = nil then
    a1:='DataSource not specified'
  else
  if fdataSource.dataset = nil then
    a1:='DataSource is missing a dataset'
  else
  if (fUseFieldDisplayList = true) and (fFieldDisplayList[0] = '') then
    a1:='UseFieldDisplayList property is true, but FieldDisplayList is empty!'
  else
  if (RelativePath = '') or (RelativePath[1] = '\') then
    a1:='Malformed or Missing RelativePath';

  Result:=a1='';
  if not result then
    WebOutput.SendComment(ClassName+': '+a1);
end;


procedure TWdbChartFX.DoExecute;
begin
  if not tpUpdated then
    exit;
  inherited DoExecute;

  {what'd you like to do now?}
  {look to tweblogo to see how you might override the execute procedure
  itself to perform different actions using a commandtype property}
end;

{---------------------------------------------------------------}

constructor TWdbChartFX.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fFieldDisplayList := TStringList.create;
  fMaxPoints := 0;
  fRelativePath := 'images\';
  fLabelXAxis := true;
  fServerBasePath := 'c:\website\htdocs\';
end;


destructor TWdbChartFX.Destroy;
begin
  fFieldDisplayList.free;
  inherited Destroy;
end;

{---------------------------------------------------------------}

{ if you pass targetdir, then the file will be created in targetdir instead
of where the TEMP= points}

function TWdbChartFX.getTmpFilename(targetdir: string): string;
var
  tmpfile : array[0..255] of char;
  newname : PChar;
begin
  getTempFilename( '0', 'gif', 0, tmpfile );
  newname := StrRScan(tmpfile, '\');
  if targetdir[length(targetdir)] = '\' then
    delete(targetdir, length(targetdir), 1);
  if targetdir = '' then
    result := strpas(tmpfile)
  else
    result := strpas(newname + 1); {removes prepended slash}
end;


function TWdbChartFX.DrawChart : Boolean;
{$IFDEF WIN32}
begin
  Result:=False;
{$ELSE}
var
  nRecords : longInt;
  i : longInt;  { record counter }
  j : integer;  { field loop counter }
  k : integer;  { memo lines loop counter }
  CurrentSeries : integer;
  x : TField;
  fldIdx : integer; { real field counter }
  nMemoLines : integer;
  s : string;

begin
 {verify required properties are set}
  Result:=False;
  if not tpUpdated then
    exit;
  nRecords := fDataSource.dataset.RecordCount;
  if fMaxPoints <> 0 then
    nRecords := fMaxPoints; { build list of field pointers }

  if not UseFieldDisplayList then begin
    fNFields := fDataSource.dataset.fieldCount;
    fChartFX.opendata[COD_VALUES] := MakeLong(fNFields-1, nRecords);
    if fNFields > MAXTABLEFIELDS then
      fNFields := MAXTABLEFIELDS;
    for j := 0 to fNFields - 1 do
      fFieldIndexList[j] := j;
    end
  else begin
    fNFields := fFieldDisplayList.count;
    fChartFX.opendata[COD_VALUES] := MakeLong(fNFields-2, nRecords);
    WebOutput.SendComment(inttostr(fNFields-2));
    if fNFields > MAXTABLEFIELDS then
      fNFields := MAXTABLEFIELDS;
    for j := 0 to fNFields - 1 do begin
      x := fDataSource.dataset.findField( fFieldDisplayList[j] );
      if x = nil then begin
        fNfields := fNFields - 1;   { remove from active list! }
        continue;
        end;
      fFieldIndexList[j] := x.fieldNo - 1;
      end;
    end;
  for j := 1 to fNFields-1 do begin
    fldIdx := fFieldIndexList[ j ];
    fChartFX.SerLeg[j-1] := fDataSource.dataset.fields[fldIdx].fieldname;
    end;

  with WebOutput, fDataSource.dataset do begin
    first; {move cursor to first record}
    for i := 1 to nRecords do begin
      if fLabelXAxis = true then
        fChartFX.Keyleg[i-1] := fields[0].asstring;
      for j := 1 to fNFields-1 do begin
        fldIdx := fFieldIndexList[ j ];
        fChartFX.ThisSerie := j-1;
        x := fields[fldIdx];
        fChartFX.Value[i-1] := fields[fldIdx].asFloat;
        end;
      next; {move db cursor to next record}
      end;
    end;

  with fChartFX do begin
    CloseData[COD_VALUES] := 0;
    title[CHART_TOPTIT] := fCaption;
    Font[CHART_TOPFT] := CF_BOLD OR 12;
    end;

  result := false;
{$ENDIF}
end;


function TWdbChartFX.MakeIMGFile(IMGType : TImgType) : string;
{$IFDEF WIN32}
begin
  Result:='';
{$ELSE}
var
  Bitmap: TBitmap;
  ImageStream: TMemoryStream;
  PtmpfileBMP: string;
  TempGifFile: string;
  tmpfileBMP: ARRAY[0..255] of char;
  tmpfileGIF: ARRAY[0..255] of char;
  retcode: boolean;
  hDev:HDC;
  hBmp,hOldBmp:HBITMAP;
  width: integer;
  height: integer;
begin
  {verify required properties are set}
  result:='';
  if not tpUpdated or (IMGType<>imgGif) then   { !!! not yet supporting other format }
    exit;

  PtmpfileBMP := getTmpFilename(ServerBasePath + RelativePath);  {create file in default dir}
  TempGifFile := getTmpFilename(ServerBasePath + RelativePath);

  StrPCopy(tmpfileBMP, ServerBasePath + RelativePath + PtmpfileBMP); {convert to null term for BMP2GIF.DLL}
  StrPCopy(tmpfileGIF, ServerBasePath + RelativePath + TempGifFile); {convert to null term for BMP2GIF.DLL}

  height := (fChartFX.height * 12) div 10;
  width  := (fChartFX.width  * 12) div 10;

  Bitmap := TBitmap.create;
  try
    hDev := CreateCompatibleDC((Owner as TForm).Canvas.Handle);
    hBmp := CreateCompatibleBitmap((Owner as TForm).Canvas.Handle,width,height);

    hOldBmp := SelectObject(hDev, hBmp);
    chart_Paint(fChartFX.Handle, hDev, 0, 0, width, height,0, 0);
    Bitmap.Handle := hBmp;
    SelectObject(hDev, hOldBmp);

    ImageStream := TMemoryStream.create;
    try
      BMPToGifStream(Bitmap, ImageStream);
      ImageStream.Savetofile(ServerBasePath + RelativePath + TempGifFile);
    finally
      ImageStream.free;
      end;

  finally
    DeleteObject(hBmp);
    DeleteDC(hDev);
    Bitmap.Free;
    TempGifFile := SwapChar(RelativePath + TempGifFile, '\', '/');
    result:='/'+TempGifFile;  {return the gif filename to caller}
    end;
{$ENDIF}
end;


procedure TWdbChartFX.SetFieldDisplayList(Value:tStringList);
begin
  fFieldDisplayList.assign(Value);
end;


function TWdbChartFX.getFileSize( filename : string ) : longint;
var
  tmpFile : file of byte;
begin
  try
    assignfile( tmpFile, filename );
    filemode := 0;
    reset( tmpFile );
    result := filesize( tmpFile );
    closeFile( tmpFile );
  except
    raise exception.create( 'error getting size of ' + filename );
    end;
end;


function TWdbChartFX.SendChartIMG(IMGType : TImgType) : Boolean;
{$IFDEF WIN32}
begin
  Result:=false;
{$ELSE}
var
  gifFile : integer;
  stdoutname : string;
  stdout : TFileStream;
  gifFilename : string;
  gifSize : longint;
  bufSize : word;
  gifbufSize : word;
  buf : pchar;
  gifbuf : TMemoryStream;
  count : longint;

begin
  buf := nil;
  gifbuf := nil;

{NO GOOD!}

  stdoutname := WebOutput.OutputFile;


  gifbuf := MakeGIFStream;   { MakeIMGFile looks for CGIReferer, which
                               could be cginotfound and therefore cause
                               writing to stdout! Therefore this call
                               must be before any other use of stdout. }
  bufsize := 4096;
  gifsize := gifbuf.size;
  try
    { adding fmCreate seems to have done the trick for NT }
    stdout := TFileStream.create( stdoutname, fmCreate OR fmOpenWrite );
  except
    raise exception.create( 'failed to open stdout: ' + stdoutname );
    exit;
    end;
  try
    getmem( buf, bufsize );
    strpcopy( buf, 'HTTP/1.0 200 OK' + #13#10 +
             'Server: ' + WebServer.CGIServerSoftware + #13#10 +
             'Date: ' + WebServer.webDate( NowGMT ) + #13#10 +
             'Expires: ' + WebServer.webDate( NowGMT + (1/(24*120)) ) + #13#10 +  {in 30 seconds}
             'Content-type: image/gif' + #13#10 + { absolutely required }
             'Content-Transfer-Encoding: 8bit' + #13#10 + { probably unnecessary }
             'Content-length: ' + intToStr( gifSize ) + #13#10#13#10 );  { optional }
    try
      { send header info defined above }
      stdout.write( buf[0], strlen(buf) );  { from CWG.HLP }
    except
      freemem( buf, bufsize );
      raise exception.create( 'write of buf failed' );
      end;

    { append the .gif image to stdout }
    try
      gifbuf.SaveToStream(stdout);
    except
      freemem( buf, bufsize );
      freemem( gifbuf, gifbufsize );
      raise exception.create( 'write of gifbuf failed' );
      end;
  finally
    gifbuf.free;
    if buf <> nil then
      freeMem( buf, bufsize );
      stdout.free;
      end;
{$ENDIF}
end;


function TWdbChartFX.MakeGIFStream: TMemoryStream;
{$IFDEF WIN32}
begin
  Result:=nil;
{$ELSE}
var
  Bitmap: TBitmap;
  retcode: boolean;
  hDev:HDC;
  hBmp,hOldBmp:HBITMAP;
  width: integer;
  height: integer;

begin
  Result:=nil;
  height:=(fChartFX.height * 12) div 10;
  width :=(fChartFX.width  * 12) div 10;
  try
    Bitmap:=TBitmap.create;
    hDev := CreateCompatibleDC((Owner as TForm).Canvas.Handle);
    hBmp := CreateCompatibleBitmap((Owner as TForm).Canvas.Handle,width,height);

    hOldBmp := SelectObject(hDev, hBmp);
    chart_Paint(fChartFX.Handle, hDev, 0, 0, width, height,0, 0);
    Bitmap.Handle := hBmp;
    SelectObject(hDev, hOldBmp);

    result:=TMemoryStream.create;
    BMPToGifStream(Bitmap, result);
  finally
    DeleteObject(hBmp);
    DeleteDC(hDev);
    Bitmap.Free;
    end;
{$ENDIF}
end;

{---------------------------------------------------------------}

//procedure Register;
//begin
//  RegisterComponents('HREF', [TWdbChartFX]);
//end;

end.