* Applied patches by "circular", bug #18863

git-svn-id: trunk@17747 -

packages/fcl-image/src/fpreadpnm.pp

@@ -19,7 +19,7 @@ The PNM (Portable aNyMaps) is a generic name for :
   PBM : Portable BitMaps,
   PGM : Portable GrayMaps,
   PPM : Portable PixMaps.
-There is no file format associated  with PNM itself.}
+There is normally no file format associated  with PNM itself.}
 
 {$mode objfpc}{$h+}
 unit FPReadPNM;
@@ -85,7 +85,7 @@ begin
     repeat
       Inc(s[0]);
       ReadBuffer(s[Length(s)+1],1)
-    until s[Length(s)+1] in WhiteSpaces;
+    until (s[0]=#7) or (s[Length(s)+1] in WhiteSpaces);
   Result:=StrToInt(s);
 end;
 
@@ -112,10 +112,10 @@ begin
   If (FWidth<=0) or (FHeight<=0) or (FMaxVal<=0) then
     Raise Exception.Create('Invalid PNM header data');
   case FBitMapType of
-    1: FBitPP := SizeOf(Word);
+    1: FBitPP := 1;                  // 1bit PP (text)
     2: FBitPP := 8 * SizeOf(Word);   // Grayscale (text)
     3: FBitPP := 8 * SizeOf(Word)*3; // RGB (text)
-    4: FBitPP := 1; // 1bit PP (row)
+    4: FBitPP := 1;            // 1bit PP (raw)
     5: If (FMaxval>255) then   // Grayscale (raw);
          FBitPP:= 8 * 2
        else
@@ -136,7 +136,7 @@ var
 begin
   ReadHeader(Stream);
   Img.SetSize(FWidth,FHeight);
-  FScanLineSize:=(FBitPP*FWidth+7) shr 3;  // (bits/line +7)
+  FScanLineSize:=FBitPP*((FWidth+7)shr 3);
   GetMem(FScanLine,FScanLineSize);
   try
     for Row:=0 to img.Height-1 do
@@ -153,18 +153,21 @@ procedure TFPReaderPNM.ReadScanLine(Row : Integer; Stream:TStream);
 
 Var
   P : PWord;
-  I,j : Integer;
+  I,j,bitsLeft : Integer;
+  PB: PByte;
 
 begin
   Case FBitmapType of
     1 : begin
-        P:=PWord(FScanLine);
+        PB:=FScanLine;
         For I:=0 to ((FWidth+7)shr 3)-1 do
           begin
-            P^:=0;
-            for j:=0 to 7 do
-              P^:=(P^ shr 1)or ReadInteger(Stream);
-            Inc(P);
+            PB^:=0;
+            bitsLeft := FWidth-(I shl 3)-1;
+            if bitsLeft > 7 then bitsLeft := 7;
+            for j:=0 to bitsLeft do
+              PB^:=PB^ or (ReadInteger(Stream) shl (7-j));
+            Inc(PB);
           end;
         end;
     2 : begin
@@ -219,26 +222,26 @@ Var
 
   Var
     P : PByte;
-    I,j,x : Integer;
+    I,j,x,bitsLeft : Integer;
 
   begin
     P:=PByte(FScanLine);
-    x:=7;
     For I:=0 to ((FWidth+7)shr 3)-1 do
       begin
       L:=P^;
-      for j:=0 to 7 do
+      x := I shl 3;
+      bitsLeft := FWidth-x-1;
+      if bitsLeft > 7 then bitsLeft := 7;
+      for j:=0 to bitsLeft do
         begin
-        if x < FWidth then
-          if odd(L) then
+          if L and $80 <> 0 then
             Img.Colors[x,Row]:=colBlack
           else
             Img.Colors[x,Row]:=colWhite;
-        L:=L shr 1;
-        dec(x);
+          L:=L shl 1;
+          inc(x);
         end;
       Inc(P);
-      Inc(x,16);
       end;
   end;
 
@@ -324,7 +327,7 @@ begin
   C.Alpha:=AlphaOpaque;
   Scale := FMaxVal*(FMaxVal+1) + FMaxVal;
   Case FBitmapType of
-    1 : ;
+    1 : ByteBnWScanLine;
     2 : WordGrayScanline;
     3 : WordRGBScanline;
     4 : ByteBnWScanLine;
@@ -340,5 +343,7 @@ begin
 end;
 
 initialization
-  ImageHandlers.RegisterImageReader ('PNM Format', 'PNM;PGM;PBM', TFPReaderPNM);
+
+  ImageHandlers.RegisterImageReader ('Netpbm format', 'PNM;PGM;PBM;PPM', TFPReaderPNM);
+
 end.

packages/fcl-image/src/fpwritepnm.pp

@@ -19,29 +19,103 @@
     * PPM (P5,P6) : Portable PixelMap foramt : 24 bits per pixel}
 {$mode objfpc}{$h+}
 unit FPWritePNM;
+
 interface
 
 uses FPImage, classes, sysutils;
 
 type
+  TPNMColorDepth = (pcdAuto,pcdBlackWhite, pcdGrayscale, pcdRGB);
+
+  { TFPWriterPNM }
 
   TFPWriterPNM = class(TFPCustomImageWriter)
-    private
-      BitMapType:Integer;
     protected
       procedure InternalWrite(Stream:TStream;Img:TFPCustomImage);override;
     public
-      constructor Create(aBitMapType:Integer);
+      ColorDepth: TPNMColorDepth;
+      BinaryFormat: boolean;
+      function GuessColorDepthOfImage(Img: TFPCustomImage): TPNMColorDepth;
+      function GetColorDepthOfExtension(AExtension: string): TPNMColorDepth;
+      function GetFileExtension(AColorDepth: TPNMColorDepth): string;
+      constructor Create; override;
+  end;
+
+  { TFPWriterPBM }
+
+  TFPWriterPBM = class(TFPWriterPNM)
+      constructor Create; override;
   end;
 
+  { TFPWriterPGM }
+
+  TFPWriterPGM = class(TFPWriterPNM)
+      constructor Create; override;
+  end;
+
+  { TFPWriterPPM }
+
+  TFPWriterPPM = class(TFPWriterPNM)
+      constructor Create; override;
+  end;
+
+procedure SaveImageToPNMFile(Img: TFPCustomImage; filename: string; UseBinaryFormat: boolean = true);
+
 implementation
 
-constructor TFPWriterPNM.Create(aBitMapType:Integer);
+procedure SaveImageToPNMFile(Img: TFPCustomImage; filename: string; UseBinaryFormat: boolean = true);
+var writer: TFPWriterPNM;
+    curExt: string;
+begin
+  writer := TFPWriterPNM.Create;
+  writer.BinaryFormat := UseBinaryFormat;
+  curExt := Lowercase(ExtractFileExt(filename));
+  if (curExt='.pnm') or (curExt='') then
   begin
-    inherited Create;
-    BitMapType:=aBitMapType;
-  end;
+    writer.ColorDepth := writer.GuessColorDepthOfImage(Img);
+    filename := ChangeFileExt(filename,'.'+writer.GetFileExtension(writer.ColorDepth));
+  end else
+    writer.ColorDepth := writer.GetColorDepthOfExtension(curExt);
+  Img.SaveToFile(filename,writer);
+  writer.Free;
+end;
+
+{ TFPWriterPPM }
+
+constructor TFPWriterPPM.Create;
+begin
+  inherited Create;
+  ColorDepth := pcdRGB;
+end;
+
+{ TFPWriterPGM }
+
+constructor TFPWriterPGM.Create;
+begin
+  inherited Create;
+  ColorDepth := pcdGrayscale;
+end;
+
+{ TFPWriterPBM }
+
+constructor TFPWriterPBM.Create;
+begin
+  inherited Create;
+  ColorDepth:= pcdBlackWhite;
+end;
+
+{ TFPWriterPNM }
+
+constructor TFPWriterPNM.Create;
+begin
+  inherited Create;
+  ColorDepth := pcdAuto;
+  BinaryFormat := True;
+end;
+
 procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage);
+var useBitMapType: integer;
+
   function SaveHeader(stream:TStream):boolean;
     const
       MagicWords:Array[1..6]OF String[2]=('P1','P2','P3','P4','P5','P6');
@@ -55,8 +129,8 @@ procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage);
           Str(Img.Width,StrWidth);
           Str(Img.Height,StrHeight);
         end;
-      PNMInfo:=Concat(MagicWords[BitMapType],#10,StrWidth,#32,StrHeight,#10);
-      if BitMapType in [2,3,5,6]
+      PNMInfo:=Concat(MagicWords[useBitMapType],#10,StrWidth,#32,StrHeight,#10);
+      if useBitMapType in [2,3,5,6]
       then
         PNMInfo:=Concat(PNMInfo,'255'#10);
       stream.seek(0,soFromBeginning);
@@ -68,18 +142,31 @@ procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage);
     aColor:TFPColor;
     aLine:PByte;
     strCol:String[3];
+    LinuxEndOfLine: char;
+    UseColorDepth: TPNMColorDepth;
+
   begin
+    LinuxEndOfLine := #10;
+
+    //determine color depth
+    if ColorDepth = pcdAuto then
+      UseColorDepth := GuessColorDepthOfImage(Img) else
+      UseColorDepth := ColorDepth;
+
+    //determine file format number (1-6)
+    case UseColorDepth of
+      pcdBlackWhite: useBitMapType := 1;
+      pcdGrayscale: useBitMapType := 2;
+      pcdRGB: useBitMapType := 3;
+    end;
+    if BinaryFormat then inc(useBitMapType,3);
+
     SaveHeader(Stream);
-    case BitMapType of
+    case useBitMapType of
       1:nBpLine:=Img.Width*2;{p p p}
       2:nBpLine:=Img.Width*4;{lll lll lll}
       3:nBpLine:=Img.Width*3*4;{rrr ggg bbb rrr ggg bbb}
-      4:begin
-          nBpLine:=Img.Width SHR 3;
-          if(Img.Width AND $0F)<>0
-          then
-            Inc(nBpLine);
-        end;
+      4:nBpLine:=(Img.Width+7) SHR 3;
       5:nBpLine:=Img.Width;
       6:nBpLine:=Img.Width*3;
     end;
@@ -91,7 +178,7 @@ procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage);
           begin
             aColor:=img.Colors[Coulumn,Row];
             with aColor do
-              case BitMapType of
+              case useBitMapType of
                 1:begin
                     if(Red<=$2F00)or(Green<=$2F00)or(Blue<=$2F00)
                     then
@@ -136,10 +223,61 @@ procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage);
             end;
           end;
         Stream.Write(aLine^,nBpLine);
+        if useBitMapType in[1..3] then Stream.Write(LinuxEndOfLine,1);
       end;
     FreeMem(aLine,nBpLine);
   end;
 
+function TFPWriterPNM.GetColorDepthOfExtension(AExtension: string
+  ): TPNMColorDepth;
+begin
+  if (length(AExtension) > 0) and (AExtension[1]='.') then
+    delete(AExtension,1,1);
+  AExtension := LowerCase(AExtension);
+  if AExtension='pbm' then result := pcdBlackWhite else
+  if AExtension='pgm' then result := pcdGrayscale else
+  if AExtension='ppm' then result := pcdRGB else
+    result := pcdAuto;
+end;
+
+function TFPWriterPNM.GuessColorDepthOfImage(Img: TFPCustomImage): TPNMColorDepth;
+var Row, Col: integer;
+    aColor: TFPColor;
+begin
+   result := pcdBlackWhite;
+   for Row:=0 to img.Height-1 do
+     for Col:=0 to img.Width-1 do
+     begin
+       aColor:=img.Colors[Col,Row];
+       if (AColor.red >= 256) and (AColor.green >= 256) and (AColor.blue >= 256) and
+          (AColor.red < $FF00) and (AColor.green < $FF00) and (AColor.blue < $FF00) then
+       begin
+          if (AColor.red shr 8 <> AColor.Green shr 8) or
+             (AColor.blue shr 8 <> AColor.Green shr 8) or
+             (AColor.red shr 8 <> AColor.blue shr 8) then
+          begin
+             result := pcdRGB;
+             exit;
+          end else
+            result := pcdGrayscale;
+       end;
+     end;
+end;
+
+function TFPWriterPNM.GetFileExtension(AColorDepth: TPNMColorDepth): string;
+begin
+  case AColorDepth of
+    pcdBlackWhite: result := 'pbm';
+    pcdGrayscale: result := 'pgm';
+    pcdRGB: result := 'ppm';
+  else
+    result := 'pnm';
+  end;
+end;
+
 initialization
-  ImageHandlers.RegisterImageWriter ('PBM Format', 'pbm', TFPWriterPNM);
+  ImageHandlers.RegisterImageWriter ('Netpbm Portable aNyMap', 'pnm', TFPWriterPNM);
+  ImageHandlers.RegisterImageWriter ('Netpbm Portable BitMap', 'pbm', TFPWriterPBM);
+  ImageHandlers.RegisterImageWriter ('Netpbm Portable GrayMap', 'pgm', TFPWriterPGM);
+  ImageHandlers.RegisterImageWriter ('Netpbm Portable PixelMap', 'ppm', TFPWriterPPM);
 end.