fjpg

Descripción del contenido de la página

Herramienta en Forth para leer información de ficheros JPEG.

Etiquetas:

Escribí este programa en Forth como complemento a otro, fhp; necesitaba leer el ancho y el alto de una imagen de formato JPEG. El programa es fácilmente ampliable para extraer otros datos.

Código fuente

\ ---------------------------------------------
cr .( fjpg )

\ Copyright (C) 2006,2007,2009,2013,2014 Marcos Cruz (programandala.net)
\ Licencia/License/Permesilo: http://programandala.net/license

\ Herramientas para leer información de archivos JPEG.
\ Info-legiloj por JPEG-dosieroj.
\ Tools to read JPEG files information.

\ Programa escrito en Forth con Gforth.
\ Programo verkita en Fortho per Gforth.
\ Program written in Forth with Gforth.

\ ---------------------------------------------
\ History

\ 2014-02-28: Typo fixed in comment.

\ 2014-02-24: Copied to Galope in order to improve it and reuse it.
\ Typos fixed in comments. '2+' and '2-' changed to '2 +' and '2 -'
\ por Gforth.

\ 2013-09-25: Changes in the source: no tabs, no spaces at the end of
\ lines, no empty lines... ANS Forth removed from the header. Forth
\ words are changed to lowercase.

\ 2009-02-20: New word: 'jpg-close'.

\ 2007-10-19: Bug found and fixed: The x and y are not found in
\ pictures taken with a Nikon Coolpix 3100.  The reason was that the
\ JPEG size header was after the first 16 KiB, the size of the used
\ buffer.  But my Forth 5mx 'read-file' word had a limitation
\ inherited from the OPL command ioread(): it could not read more than
\ 16 KiB in a single operation.  So i wrote a new OPL procedure to
\ call ioread as many times as needed to read the desired lenght.
\ Then I increased the JPEG buffer to 64 KiB, what seems enough...
\ 'jpg-search2' and 'jpg-search-xy' were written for debugging this.

\ 2006-04-03: '.jpg-data' improved: Now you can 'abort' also *before*
\ the dumping.  'jpg-dump' modified: Now it doesn't show the data
\ bytes out of the headers.

\ 2006-04-02: '.jpg-data' improved: Now it asks for confirmation
\ *before* the dumping.

\ 2006-04-01: 'jpg-xy' fixed: it returned y x insted of x y.

\ 2006-03-30: First working version of 'jpg-xy'.

\ 2006-03-29: First working version of 'jpg-dump'.

\ 2006-03-28: Start. My first goal is to get the width and height of a
\ JPEG image file.  i need that to improve my program fhp, a Forth
\ HTML Preprocessor.

\ ---------------------------------------------

marker fjpg

: 16@  ( c-addr -- n )
  \ Fetch litle-endian 16 bits.
  dup c@ 256 * swap 1+ c@ +
  ;
65536 constant #jpg-buffer  \ must be enough to hold all JPEG headers we will need
create jpg-buffer #jpg-buffer allot
: jpg-load  ( fileid -- )
  \ Fill the buffer with the beginning of the a jpeg image file, to make it the current one.
  [ base @ hex ]
  jpg-buffer #jpg-buffer
  2dup erase
  rot read-file abort" Read image file error in jpg-load ."
  drop jpg-buffer @ ffff and d8ff <> abort" Not a JPEG file in jpg-load ."
  [ base ! ]
  ;
variable jpg-fileid
: jpg-open  ( c-addr u -- fileid )
  \ Open a JPEG image file and make it the current one.
  [ base @ hex ]
  r/o bin open-file abort" JPEG image open file error in jpg-open ."
  dup jpg-fileid !
  dup jpg-load
  [ base ! ]
  ;
: jpg-close  ( -- )
  \ Close the current JPEG image.
  jpg-fileid @ close-file abort" JPEG image close file error in jpg-close ."
  ;
: >jpg-data  ( c-addr -- c-addr2 u2 )
  \ c-addr = address of a JPEG marker
  \ c-addr2 u2 = data region of the JPEG header
  dup 4 + swap 2 + 16@ 2 -
  ;
: >jpg-marker  ( c-addr -- u )
  \ c-addr = address of a JPEG marker
  \ u = byte offset from c-addr to the next JPEG marker
  2 + 16@ 2 +
  ;
: .jpg-data  ( c-addr u -- )
  \ Dump the data of a JPEG header.
  cr ." [d]ump? [a]bort? Any other key to continue" cr
  key  case
  [char] d
    of
      cr dump
      ." [a]bort? Any other key to continue" cr
      key [char] a =
      if  abort  then
    endof
  [char] a  of  abort  endof
  >r 2drop r>  \ discard data, savig the case selector
  endcase
  ;
: .jpg-header  ( c-addr -- u )
  \ show a jpeg header.
  \ c-addr = address of a jpeg marker
  \ u = byte offset from c-addr to the next marker
  dup >jpg-data 2dup
  ." , " . ." bytes from " . ." :"
  .jpg-data  >jpg-marker
  ;
: >jpg-xy  ( c-addr -- x y )
   \ c-addr = address of the proper jpeg marker
   \ x y = size of the jpeg image
  7 + dup 16@ swap 2 - 16@
  ;
: .jpg-xy  ( c-addr -- )
  \ show the jpeg image size.
  \ c-addr = address of the proper jpeg marker
  >jpg-xy swap ."  x=" . ." y=" .
  ;
: jpg-header  ( c-addr -- n )
  \ identify and show a new jpeg header.
  \ c-addr = address of the jpeg marker
  \ u = byte offset to the next marker, or 0 if the marker found was the end of image
  [ base @ hex ]
  dup 1+ c@  dup .  ." marker: "
  case  \ marker id
  c0  of  ." frame" dup .jpg-xy .jpg-header  endof
  c1  of  ." unknown (frame?)" dup .jpg-xy .jpg-header  endof  \ xxx debug 2007-10-19
  c2  of  ." unknown (frame?)" dup .jpg-xy .jpg-header  endof
  c3  of  ." unknown (frame?)" dup .jpg-xy .jpg-header  endof  \ xxx debug 2007-10-19
  c4  of  ." define huffman table" .jpg-header  endof
  \ from e0 to ef are reserved for applications:
  e0  of  ." jfif" .jpg-header  endof
  e1  of  ." exim" .jpg-header  endof
  d8  of  ." start of image" drop 2  endof
  d9  of  ." end of image" drop 0  endof
  da  of  ." start of scan" .jpg-header  endof
  db  of  ." define quantization" .jpg-header  endof
  fe  of  ." comment" .jpg-header  endof
  >r  \ preserve case selector for endcase
  ." unknown" .jpg-header
  r>
  endcase
  [ base ! ]
  ;
: jpg-xy  ( -- x y )
  \ return the size of the current jpeg file.
  [ base @ hex ]
  jpg-buffer dup #jpg-buffer + swap 2 +
  do
    i 16@
    case
    ffc0  of  i >jpg-xy leave  endof
    ffc2  of  i >jpg-xy leave  endof
    endcase
    i >jpg-marker
  +loop
  [ base ! ]
  ;
\ debug tools
: jpg-dump  ( -- )
  \ dump the content of the current jpeg image, header after header, until the buffer end.
  \ this word was written to learn about the jpeg format and write the other words.
  [ base @ hex ]
  jpg-buffer dup #jpg-buffer + swap
  do
    i dup cr . ." : "
    dup c@ dup .
    ff =
    if
      jpg-header
    else
      \ ."  byte out of header: " c@ .  1
      drop 1
    then
    dup 0= abort" end of jpeg image in jpg-dump ."
  +loop
  [ base ! ]
  ;
0 value jpg-searched  \ byte
: jpg-search  ( b -- )
  \ search a byte in the current jpeg file.
  \ this word was written to find out where the image width and height are stored.
  to jpg-searched  cr
  #jpg-buffer jpg-buffer + jpg-buffer
  do
    [char] . emit
    i c@ jpg-searched =
    if
      cr jpg-searched . ."  found at " i .
      i 16 - 32 .jpg-data
    then
  loop
  ;
0 value jpg-searched2 \ byte
defer jpg-found2
: (jpg-found2)  ( c-addr -- )
  \ default action after a successful search of two bytes.
  32 .jpg-data
  ;
' (jpg-found2) is jpg-found2
: jpg-search2  ( b1 b2 -- )
  \ Search the current JPEG file for two bytes.
  to jpg-searched2
  to jpg-searched  cr
  #jpg-buffer jpg-buffer + jpg-buffer
  do
    [char] . emit
    i c@ jpg-searched =
    i 1+ c@ jpg-searched2 = and
    if  jpg-found2  then
  loop
  ;
: jpg-search-xy  ( -- )
  \ Search and show any possible frame header in the current JPEG file.
  \ This word was written to find out why the size
  \ could not be found in pictures taken with a Nikon Coolpix 3100.
  [ base @ hex ]
  ' jpg-xy is jpg-found2
  ff c0 jpg-searched2
  ' (jpg-found2) is jpg-found2
  [ base ! ]
  ;

\ ---------------------------------------------
\ Testing

false [if]

: jpg-test  ( c-addr u -- )
  \ Test an image
  \ c-addr u = image file
  jpg-open
  jpg-dump
  jpg-close
  ;
: img1  s" c:\tmp\20071001153657_muestra.jpg"  ;
: img2  s" c:\tmp\alforja-saco\200709261743_alforjas_saco.jpg"  ;
: img3  s" c:\tmp\alforja-saco\200709261742_alforjas_saco.jpg"  ;
img1 jpg-test
img2 jpg-test
img3 jpg-test

[then]

.(  fjpg ok!)

Descargas

fjpg.fs (7.47 KiB)