{ Some utility routines dealing with pictures.

  They need `identify' and `convert' from the ImageMagick package,
  `pngtopnm', `pnmtopng', `pnmscale' and `pnmflip' from the NetPBM
  package as well as `cjpeg', `djpeg' and `jpegtran', from the JPEG
  package. All of those programs must be found in the PATH.

  Copyright (C) 2003-2005 Frank Heckenbach <frank@pascal.gnu.de>

  This unit 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, or (at your
  option) any later version.

  This unit 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 unit; see the file COPYING. If not, write to the
  Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  02111-1307, USA. }

{ Define in order to use libjpeg directly to determine the size of
  JPEG files (much faster). Otherwise ImageMagick will be used.
  Defining it also makes JPEGFindEndOfFile available. }
{$define USE_LIBJPEG}

{$gnu-pascal,I-}
{$if __GPC_RELEASE__ < 20041017}
{$error This program requires GPC release 20041017 or newer.}
{$endif}

unit PictureUtils;

interface

uses GPC, Pipes;

const
  PNGID = #137'PNG'#13#10#26#10;
  JPEGID = #$ff#$d8;

type
  TPictureRotate = (pr_None, pr_90, pr_180, pr_270, pr_MirrorH, pr_MirrorUL, pr_MirrorV, pr_MirrorUR);

{ Get the size of a picture. }
function PictureSize (const FileName: String; var Width, Height: Integer): Boolean;

{ Create a picture thumbnail if it doesn't exist or is older than
  the source picture. }
function PictureConvert (const Src, Dest, Geometry, Quality: String; Verbose: Boolean): Boolean;

{ Dest should be an unopened file. It will be opened to a stream
  (possibly a pipe) to read the converted image from. }
procedure PictureRotate (const Src: String; var Dest: AnyFile; Direction: TPictureRotate);

function PNGSize (const FileName: String; var Width, Height: Integer): Boolean;

{$ifdef USE_LIBJPEG}
function JPEGFindEndOfFile (function GetByte: CInteger): CInteger; external name 'JPEGFindEndOfFile'; attribute (ignorable);
{$endif}

type
  PImg = ^TImg;
  TImg (x, y: Integer) = record
    Next: PImg;
    Count: Integer;
    Img: array [0 .. y - 1, 0 .. x - 1] of record
         case Boolean of
           False: (r, g, b: Byte);
           True:  (cy, cu, cv: Byte);
         end
  end;

{ Can return a list of images if the file contains multiple images.
  Does not return nil unless Error was called. }
function ReadImg (const FileName, Geometry: String; procedure Error (const Msg: String)) = Res: PImg;

{ Writes a single image in JPEG, PNG or PPM format, depending on FileName. }
procedure WriteImg (Image: PImg; const FileName: String);

implementation

{$ifdef USE_LIBJPEG}
{$L pictureutilsc.c, jpeg}
function JPEGSize (FileName: CString; var Width, Height: CInteger): CInteger; external name 'JPEGSize';
{$endif}

function PNGSize (const FileName: String; var Width, Height: Integer): Boolean;
var
  b: array [1 .. 16] of Char;
  w, h: Integer attribute (Size = 32);
  f: file;
begin
  PNGSize := False;
  Reset (f, FileName, 1);
  BlockRead (f, b, SizeOf (b));
  BlockReadBigEndian (f, w, SizeOf (w), 1);
  BlockReadBigEndian (f, h, SizeOf (h), 1);
  Close (f);
  if (IOResult <> 0) or (b[1 .. Length (PNGID)] <> PNGID) then Exit;
  Width := w;
  Height := h;
  PNGSize := True
end;

function PictureSize (const FileName: String; var Width, Height: Integer): Boolean;
var
  Status, i, j, k, e1, e2: Integer;
  CWidth, CHeight: CInteger;
  Process: PPipeProcess;
  Parameters: TPStrings (2);
  s: TString;
  f: Text;
begin
  PictureSize := False;
  Width := 0;
  Height := 0;
  if not FileExists (FileName) then Exit;
  if IsSuffixCase ('.png', FileName) and PNGSize (FileName, Width, Height) then Return True;
  {$ifdef USE_LIBJPEG}
  if (IsSuffixCase ('.jpg', FileName) or IsSuffixCase ('.jpeg', FileName)) and (JPEGSize (FileName, CWidth, CHeight) <> 0) then
    begin
      Width := CWidth;
      Height := CHeight;
      PictureSize := True;
      Exit
    end;
  {$endif}
  Parameters[1] := @'-ping';
  Parameters[2] := PString (@FileName);
  Pipe (Null, f, Null, 'identify', Parameters, GetCEnvironment, Process, nil);
  if (IOResult <> 0) or (Process = nil) then Exit;
  Process^.Status := @Status;
  while not EOF (f) do
    begin
      ReadLn (f, s);
      i := Pos (' ', s);
      i := PosFrom ('x', s, i + 1);
      if i <> 0 then
        begin
          j := LastPosTill (' ', s, i);
          k := CharPosFrom ([' ', '+'], s, i);
          if (j <> 0) and (j < i - 1) and (k <> 0) and (k > i + 1) then
            begin
              Val (s[j + 1 .. i - 1], Width, e1);
              Val (s[i + 1 .. k - 1], Height, e2);
              if (e1 = 0) and (e2 = 0) then PictureSize := True
            end
        end
    end;
  Close (f);
  if Status <> 0 then PictureSize := False
end;

function PictureConvert (const Src, Dest, Geometry, Quality: String; Verbose: Boolean): Boolean;
type TID = array [1 .. Length (PNGID)] of Char;
var
  Status, n, i, j, k, x, y: Integer;
  IsPNG, IsJPEG: Boolean;
  Scale: Real;
  Process: PPipeProcess;
  Parameters: PPStrings;
  Cmd, Geometry1, Geometry2, Geometry3, s, t: TString;
  f, g: file;
  FID: file of TID;
  ID: TID;
begin
  PictureConvert := True;
  if FileExists (Dest) then
    begin
      Assign (f, Src);
      Assign (g, Dest);
      if Binding (g).ModificationTime >= Binding (f).ModificationTime then Exit;
      if Verbose then WriteLn (StdErr, 'Updating thumbnail ', Dest)
    end
  else
    if Verbose then WriteLn (StdErr, 'Creating thumbnail ', Dest);
  t := Dest;
  i := LastCharPos (DirSeparators, t);
  Insert ('tmp-', t, i + 1);
  IsPNG := False;
  IsJPEG := False;
  Reset (FID, Src);
  if (IOResult = 0) and (FileSize (FID) > 0) then
    begin
      Read (FID, ID);
      IsPNG := (IOResult = 0) and (ID[1 .. Length (PNGID)] = PNGID);
      IsJPEG := (IOResult = 0) and (ID[1 .. Length (JPEGID)] = JPEGID)
    end;
  Close (FID);
  InOutRes := 0;
  if IsPNG or IsJPEG then
    begin
      { convert adds transparency unasked for and some versions of Netscape can't handle it well.
        Also, it's much slower and more memory hungry, to the point of being unusable, with large images. }
      s := '"$1"';
      Geometry1 := Geometry;
      Geometry2 := '';
      Geometry3 := '';
      if IsSuffix ('%', Geometry) then
        begin
          Val (Copy (Geometry, 1, Length (Geometry) - 1), Scale, i);
          if i = 0 then WriteStr (Geometry1, Scale / 100 : 0 : 8)
        end
      else
        begin
          i := Pos ('x', Geometry);
          if i <> 0 then
            begin
              Val (Copy (Geometry, 1, i - 1), x, j);
              Val (Copy (Geometry, i + 1), y, k);
              if (j = 0) and (k = 0) then
                begin
                  Geometry1 := '-xysize';
                  WriteStr (Geometry2, x);
                  WriteStr (Geometry3, y);
                  { This is done so we can use shell quoting (possible security
                    issue, depending on where the arguments come from). }
                  s := '"$1" "$2" "$3"'
                end
            end
        end;
      if IsPNG then
        s := 'PATH="$PATH:/usr/X11R6/bin"; pngtopnm "$4" | pnmscale ' + s + ' | pnmtopng > "$5"'
      else
        s := 'PATH="$PATH:/usr/X11R6/bin"; djpeg "$4" | pnmscale ' + s + ' | cjpeg > "$5"';
      Cmd := 'sh';
      New (Parameters, 8);
      Parameters^[1] := @'-c';
      Parameters^[2] := @s;
      Parameters^[3] := @'picture-convert-sh';
      Parameters^[4] := @Geometry1;
      Parameters^[5] := @Geometry2;
      Parameters^[6] := @Geometry3;
      Parameters^[7] := PString (@Src);
      Parameters^[8] := @t
    end
  else
    begin
      Cmd := 'convert';
      n := 0;
      if Quality <> '' then Inc (n, 2);
      New (Parameters, n + 4);
      Parameters^[1] := @'-geometry';
      Parameters^[2] := PString (@Geometry);
      if Quality <> '' then
        begin
          Parameters^[3] := @'-quality';
          Parameters^[4] := PString (@Quality)
        end;
      Parameters^[n + 3] := PString (@Src);
      Parameters^[n + 4] := @t
    end;
  Pipe (Null, Null, Null, Cmd, Parameters^, GetCEnvironment, Process, nil);
  Dispose (Parameters);
  if (IOResult <> 0) or (Process = nil) then
    begin
      PictureConvert := False;
      Exit
    end;
  Process^.Status := @Status;
  if not WaitPipeProcess (Process) or (Status <> 0) then
    PictureConvert := False
  else
    begin
      Assign (g, t);
      FileMove (g, Dest, True)
    end
end;

procedure PictureRotate (const Src: String; var Dest: AnyFile; Direction: TPictureRotate);
const
  JPEGTranOptions: array [Succ (Low (TPictureRotate)) .. High (TPictureRotate)] of String (16) =
    ('-rotate 90', '-rotate 180', '-rotate 270',
     '-flip horizontal', '-transverse', '-flip vertical', '-transpose');
  PNMFlipOptions: array [Succ (Low (TPictureRotate)) .. High (TPictureRotate)] of String (16) =
    ('-rotate270', '-rotate180', '-rotate90', '-leftright', '-transpose', '-topbottom', '-transpose');
var
  Width, Height: Integer;
  Parameters: TPStrings (4);
  JPEG: Boolean;
  s: TString;
begin
  if Direction = pr_None then
    Reset (Dest, Src)
  else
    begin
      { Use jpegtran if possible. It is exact and can be much faster,
        but works only on JPEG images of "round" dimensions. }
      JPEG := IsSuffixCase ('.jpg', Src) or IsSuffixCase ('.jpeg', Src);
      if JPEG and PictureSize (Src, Width, Height) and (Width mod 16 = 0) and (Height mod 16 = 0) then
        s := 'jpegtran -copy all ' + JPEGTranOptions[Direction] + ' "$1"'
      else
        begin
          s := 'convert "$1" pnm:- | pnmflip ' + PNMFlipOptions[Direction];
          if Direction = pr_MirrorUL then s := s + ' | pnmflip -rotate180';
          if JPEG then
            s := s + ' | convert - jpeg:-'
          else if IsSuffixCase ('.png', Src) then
            s := s + ' | convert - png:-'
        end;
      s := 'PATH="$PATH:/usr/X11R6/bin"; ' + s;
      Parameters[1] := @'-c';
      Parameters[2] := @s;
      Parameters[3] := @'picture-rotate-sh';
      Parameters[4] := PString (@Src);
      Pipe (Null, Dest, Null, 'sh', Parameters, GetCEnvironment, Null, nil)
    end
end;

function ReadImg (const FileName, Geometry: String; procedure Error (const Msg: String)) = Res: PImg;
var
  Count: Integer;
  p: PImg;

  procedure DoRead;
  type
    TGrayImg (x, y: Integer) = record
      Img: array [0 .. y - 1, 0 .. x - 1] of Byte
    end;
  var
    Gray, Done: Boolean;
    t: Byte;
    x, y, i, j, c: Integer;
    PRes: ^PImg;
    Img: PImg;
    GrayImg: ^TGrayImg;
    Parameters1: TPStrings (1);
    Parameters2: TPStrings (2);
    Parameters4: TPStrings (4);
    s: TString;
    f: Text;

    function ChkInOutRes: Boolean;
    begin
      ChkInOutRes := False;
      if InOutRes = 0 then Exit;
      Error (GetIOErrorMessage);
      Dispose (Img);
      Close (f);
      ChkInOutRes := True
    end;

  begin
    Count := 0;
    Res := nil;
    PRes := @Res;
    Img := nil;
    if Geometry <> '' then
      begin
        Parameters4[1] := @'-geometry';
        Parameters4[2] := PString (@Geometry);
        Parameters4[3] := PString (@FileName);
        Parameters4[4] := @'ppm:-';
        Pipe (Null, f, Null, 'convert', Parameters4, GetCEnvironment, Null, nil);
        ReadLn (f, s);
        if ChkInOutRes then Exit
      end
    else
      begin
        Reset (f, FileName);
        if ChkInOutRes then Exit;
        ReadLn (f, s);
        if ChkInOutRes then Exit;
        if (s <> 'P6') and (s <> 'P5') then
          begin
            Close (f);
            if IsSuffixCase ('.jpg', FileName) or IsSuffixCase ('.jpeg', FileName) then
              begin
                Parameters1[1] := PString (@FileName);
                Pipe (Null, f, Null, 'djpeg', Parameters1, GetCEnvironment, Null, nil)
              end
            else
              begin
                Parameters2[1] := PString (@FileName);
                Parameters2[2] := @'ppm:-';
                Pipe (Null, f, Null, 'convert', Parameters2, GetCEnvironment, Null, nil)
              end;
            ReadLn (f, s);
            if ChkInOutRes then Exit
          end
      end;
    if (s <> 'P6') and (s <> 'P5') then
      begin
        Close (f);
        Error (FileName + ': unsupported image format');
        Exit
      end;
    repeat
      Gray := s = 'P5';
      while (InOutRes = 0) and (f^ = '#') do ReadLn (f);
      Read (f, x, y, c);
      if ChkInOutRes then Exit;
      if (c <> 255) or (x < 1) or (y < 1) then
        begin
          Close (f);
          Error (FileName + ': unsupported image format');
          Exit
        end;
      if EOF (f) then ReadLn (f);
      New (Img, x, y);
      Img^.Next := nil;
      if f^ = ' ' then Get (f);
      if Gray then
        begin
          New (GrayImg, x, y);
          BlockRead (file (f), GrayImg^.Img, SizeOf (GrayImg^.Img));
          for j := 0 to y - 1 do
            for i := 0 to x - 1 do
              with Img^.Img[j, i] do
                begin
                  t := GrayImg^.Img[j, i];
                  r := t;
                  g := t;
                  b := t
                end
        end
      else
        BlockRead (file (f), Img^.Img, SizeOf (Img^.Img));
      if ChkInOutRes then Exit;
      PRes^ := Img;
      PRes := @Img^.Next;
      Img := nil;
      Inc (Count);
      Done := EOF (f);
      if not Done then
        begin
          ReadLn (f, s);
          if ChkInOutRes then Exit
        end
    until Done;
    Close (f)
  end;

begin
  DoRead;
  p := Res;
  while p <> nil do
    begin
      p^.Count := Count;
      Dec (Count);
      p := p^.Next
    end
end;

procedure WriteImg (Image: PImg; const FileName: String);
var
  f: Text;
  Parameters: TPStrings (2);
begin
  if IsSuffixCase ('.jpg', FileName) or IsSuffixCase ('.jpeg', FileName) then
    begin
      Parameters[1] := @'-outfile';
      Parameters[2] := PString (@FileName);
      Pipe (f, Null, Null, 'cjpeg', Parameters, GetCEnvironment, Null, nil)
    end
  else if IsSuffixCase ('.png', FileName) then
    begin
      Parameters[1] := @'ppm:-';
      Parameters[2] := PString (@FileName);
      Pipe (f, Null, Null, 'convert', Parameters, GetCEnvironment, Null, nil)
    end
  else
    Rewrite (f, FileName);
  WriteLn (f, 'P6');
  WriteLn (f, Image^.x, ' ', Image^.y, ' 255');
  BlockWrite (file (f), Image^.Img, SizeOf (Image^.Img));
  Close (f)
end;

end.