freepascal.compiler/packages/fcl-web/examples/fptemplate/fileupload/webmodule/webmodule.pas

unit webmodule; 

{$mode objfpc}{$H+}

interface

uses
  SysUtils, Classes, httpdefs, fpHTTP, fpWeb;

type

  { TFPWebModule1 }

  TFPWebModule1 = class(TFPWebModule)
    procedure DataModuleAfterResponse(Sender: TObject; AResponse: TResponse);
    procedure DataModuleCreate(Sender: TObject);
    procedure listfilesRequest(Sender: TObject; ARequest: TRequest;
      AResponse: TResponse; var Handled: Boolean);
  private
    { private declarations }
    UploadDir:String;
    FileDB:String;
    MaxSize:Integer;
    procedure DeleteTheFile(const FN:String);
    procedure HandleUploadedFiles;
    procedure listfilesReplaceTag(Sender: TObject; const TagString:String;
      TagParams: TStringList; Out ReplaceText: String);
  public
    { public declarations }
  end; 

var
  FPWebModule1: TFPWebModule1; 

implementation

{$R *.lfm}

{ TFPWebModule1 }

//In real applications, CopyFile should be used from unit FileUtil of the LCL
function CopyTheFile(const SrcFilename, DestFilename: String): Boolean;
var SrcFS, DestFS: TFileStream;
begin
  Result := False;
  SrcFS := TFileStream.Create(SrcFilename, fmOpenRead or fmShareDenyWrite);
  try
    DestFS := TFileStream.Create(DestFilename, fmCreate);
    try
      DestFS.CopyFrom(SrcFS, SrcFS.Size);
    finally
      DestFS.Free;
    end;
  finally
    SrcFS.Free;
  end;
  Result := True;
end;

procedure TFPWebModule1.DataModuleAfterResponse(Sender: TObject;
  AResponse: TResponse);
begin
  //reset global variables for apache modules for the next incoming request

  //
end;

procedure TFPWebModule1.DataModuleCreate(Sender: TObject);
begin
  UploadDir := 'upfiles/';
  FileDB := 'filelist.txt';
  MaxSize := 2;//MB
end;

procedure TFPWebModule1.DeleteTheFile(const FN:String);
var
  FDB: TStringList;
  s:String;
begin
  FDB := TStringList.Create;
  if FileExists(FileDB) then
    FDB.LoadFromFile(FileDB);

  s := FDB.Values[FN];
  if s <> '' then
  begin
    FDB.Delete(FDB.IndexOfName(FN));
    FDB.SaveToFile(FileDB);
    FDB.Free;
  end else begin
    FDB.Free;
    Request.QueryFields.Add('_MSG=NOTFOUND');//NOTFOUND message will be displayed on the response page
    Exit;
  end;

  //delete the file
  s := UploadDir + FN;
  if FileExists(s) then
    DeleteFile(s);
end;

procedure TFPWebModule1.HandleUploadedFiles;
var
  i:Integer;
  all_ok:Boolean;
  FDB: TStringList;
  Uploader, FN:String;
begin
  if Request.Files.Count <= 0 then Exit;

  //process the uploaded files if there was any
  all_ok := true;
  for i := 0 to Request.Files.Count - 1 do
  begin//check sizes
    if Request.Files[i].Size > (MaxSize * 1024 * 1024) then
    begin//exceeds size limit
      all_ok := false;
      Request.QueryFields.Add('_MSG=TOOBIG');//TOOBIG message will be displayed on the response page
      break;
    end;
  end;

  if all_ok then //copy the file(s) to the upload directory (the temporary files will be deleted automatically after the request is handled)
  begin
    Uploader := Request.ContentFields.Values['UPLOADERPERSON'];
    if Uploader = '' then
      Uploader := '-';
    FDB := TStringList.Create;
    if FileExists(FileDB) then
      FDB.LoadFromFile(FileDB);
    for i := 0 to Request.Files.Count - 1 do
    begin
      FN := Request.Files[i].FileName;
      if (FN <> '')and(Request.Files[i].Size > 0) then
      begin
        CopyTheFile(Request.Files[i].LocalFileName, UploadDir + FN);//copy (or overwrite) the file to the upload dir
        if FDB.Values[FN] <> '' then
          FDB.Values[FN] := Uploader                              //overwrite the previous uploader
        else
          FDB.Add(FN + '=' + Uploader);                           //store the file and the uploader into the file database
      end;
    end;
    FDB.SaveToFile(FileDB);
    FDB.Free;
  end;
end;

procedure TFPWebModule1.listfilesRequest(Sender: TObject; ARequest: TRequest;
  AResponse: TResponse; var Handled: Boolean);
var
  FN:String;
begin
  //ModuleTemplate is a web module global property
  //To use the Template propery of the current web action (which is visible in
  //the object inspector for every Action), use
  //(Sender as TFPWebAction).Template.FileName := 'mytemplate1.html'; and so on.
  ModuleTemplate.FileName := 'uploadform.html';
  ModuleTemplate.AllowTagParams := true;
  ModuleTemplate.StartDelimiter := '{+';
  ModuleTemplate.EndDelimiter := '+}';
  ModuleTemplate.OnReplaceTag := @listfilesReplaceTag;

  FN := ARequest.QueryFields.Values['DELETE'];
  if FN <> '' then
    DeleteTheFile(FN)
  else
    HandleUploadedFiles;

  AResponse.Content := ModuleTemplate.GetContent;//Generate the response page using the template

  Handled := true;
end;

procedure TFPWebModule1.listfilesReplaceTag(Sender: TObject; const TagString:
  String; TagParams: TStringList; Out ReplaceText: String);
var
  SL:TStringList;
  i:Integer;
  FileName, Uploader, One_Row:String;
begin
  if AnsiCompareText(TagString, 'DATETIME') = 0 then
  begin
    ReplaceText := FormatDateTime(TagParams.Values['FORMAT'], Now);
  end else

  if AnsiCompareText(TagString, 'MAX_SIZE') = 0 then
  begin
    ReplaceText := IntToStr(MaxSize);
  end else

  if AnsiCompareText(TagString, 'UPLOAD_DIR') = 0 then
  begin
    ReplaceText := UploadDir;
  end else

  if AnsiCompareText(TagString, 'MESSAGES') = 0 then
  begin
    ReplaceText := TagParams.Values[Request.QueryFields.Values['_MSG']];
  end else

  if AnsiCompareText(TagString, 'FILELIST') = 0 then
  begin
    SL := TStringList.Create;
    if FileExists(FileDB) then
      SL.LoadFromFile(FileDB);
    if SL.Count > 0 then
    begin
      One_Row := TagParams.Values['ONE_ROW'];
      for i := 0 to SL.Count - 1 do
      begin
        FileName := SL.Names[i];
        Uploader := SL.Values[FileName];
        if (FileName <> '')and(Uploader <> '') then
          ReplaceText := ReplaceText + StringReplace(StringReplace(StringReplace(One_Row
                                       ,'~FILENAME', FileName, [])
                                       ,'~UPLOADER', Uploader, [])
                                       ,'~DFILENAME', HTTPEncode(FileName), []) + #13#10;
      end;
    end else begin
      ReplaceText := TagParams.Values['NOTHINGTOLIST'];
    end;
    SL.Free;
  end else

  {Message for tags not handled}
  begin
    ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
  end;
end;

initialization
  RegisterHTTPModule('TFPWebModule1', TFPWebModule1); 
end.