The Devil's Doorknob BBS Capture (1996-2003)/devilsdoorknobbbscapture1996-2003.iso/Dloads/UTILITIE/VOCSHO.ZIP/VOC_IO.PKG

Text File | 1991-01-07 | 12KB | 364 lines

package body VOC_IO is
  use voc_data;
  pragma Optimize(Time);

  type One_Byte_Naturals is range 0 .. 255;
   for One_Byte_Naturals'Size use 8;
  type Two_Byte_Naturals is range 0 .. 65535;
   for Two_Byte_Naturals'Size use 16;

  type file_type_descriptions is array(0 .. 16#13#) of one_byte_naturals;

  type Headers is record
    File_Type_Description : file_type_descriptions;
    Offset_Of_Data_Block  : dos_io.byte_counts;
    version_minor         : one_byte_naturals;
    version_major         : one_byte_naturals;
    id_code_minor         : one_byte_naturals;
    id_code_major         : one_byte_naturals;
  end record;

  Headers_Bytes:constant Dos_IO.Byte_Counts
    :=Dos_IO.Byte_Counts(Headers'Size/8);

  type block_headers is record
    block_type : block_types;
    blklen     : blklens;
  end record;

  block_header_length:constant:=4;

  function "-" (Left,
                Right   : in     Dos_IO.Byte_Counts)
    return Dos_IO.Byte_Counts renames Dos_IO."-";

  function "=" (Left,
                Right   : in     Dos_IO.Byte_Counts)
    return Boolean renames Dos_IO."=";

  function ">" (Left,
                Right   : in     Dos_IO.Byte_Counts)
    return Boolean renames Dos_IO.">";

  procedure Open(Name    : in     String;
                 Handle  : in out Handles) is
    Header  : Headers;
  begin
    begin
      Dos_IO.Open(Name, Handle.File_Handle);
    exception
      when dos_io.name_error => raise name_error;
    end;
    handle.is_input:=true;
    if Dos_IO.Read(Handle.File_Handle, Header'Address, Headers_Bytes)
       /= Headers_Bytes then
      Dos_IO.Close(Handle.File_Handle);
      raise Data_Error;
    end if;
    if 16#12#-header.version_major /= header.id_code_major then
      raise data_error;
    end if;
    if 16#33#-header.version_minor /= header.id_code_minor then
      raise data_error;
    end if;
    if header.offset_of_data_block /= headers_bytes then
      Dos_IO.Skip(Handle.File_Handle,
                  headers_bytes-header.offset_of_data_block);
    end if;
    handle.voice_info:=(voice_to_continue=>false);
  end Open;

  procedure Read(Handle  : in out Handles;
                 block   :    out VOC_data.blocks) is
    this_type    : VOC_data.block_types;
    block_length : VOC_data.block_lengths;
    sample_rate  : VOC_data.sample_rates;
    null_byte    : one_byte_naturals;
    blklen       : blklens;
    function this_length return blklens is
      blklen:blklens;
    begin
      blklen:=0;  -- zero out 4th allocated byte, assume Intel format
      if dos_io.read(handle.file_handle,blklen'address,3) /= 3 then
        raise Status_Error;
      end if;
      return blklen;
    end this_length;
    function this_rate return voc_data.sample_rates is
      type srs is range 0 .. 255;
       for srs'size use 8;
      sr:srs;
    begin
      if dos_io.read(handle.file_handle,sr'address,1) /= 1 then
        raise Status_Error;
      end if;
      return voc_data.sample_rates(1000000/(256-long_integer(sr)));
    end this_rate;
    function this_pack return voc_data.pack_types is
      type packs is range 0 .. 255;
       for packs'size use 8;
      pack:packs;
    begin
      if dos_io.read(handle.file_handle,pack'address,1) /= 1 then
        raise Status_Error;
      end if;
      return voc_data.pack_types'val(pack);
    end this_pack;
    function this_2 return two_byte_naturals is
      n:two_byte_naturals;
    begin
      if dos_io.read(handle.file_handle,n'address,2) /= 2 then
        raise Status_Error;
      end if;
      return n;
    end this_2;
    procedure get_sound is
      chunk_length:dos_io.byte_counts;
    begin
      if handle.voice_info.remaining_length > blklens(max_sound_length) then
        chunk_length:=dos_io.byte_counts(max_sound_length);
      else
        chunk_length:=dos_io.byte_counts(handle.voice_info.remaining_length);
      end if;
      block:=(voice_data,integer(chunk_length),
              handle.voice_info.sample_rate,
              handle.voice_info.packing,
              data=>(others=>0));
      if dos_io.read(handle.file_handle,block.data(1)'address,
                     chunk_length) /= chunk_length then
        raise data_error;
      end if;
      handle.voice_info.remaining_length
        :=handle.voice_info.remaining_length-blklens(chunk_length);
    end get_sound;
  begin
    if not handle.is_input then
      raise status_error;
    end if;
    if handle.terminated then
      block:=(terminator,0);
      return;
    end if;
    if not Dos_IO.Is_Open(Handle.File_Handle) then
      raise Status_Error;
    end if;
    if handle.voice_info.voice_to_continue and then
       handle.voice_info.remaining_length > 0 then
      get_sound;
      return;
    end if;
    if dos_IO.read(handle.file_handle,this_type'address,1) /= 1 then
      raise data_error;
    end if;
    case this_type is
      when terminator =>
        handle.terminated:=true;
        block:=(terminator,0);
      when voice_data =>
        blklen:=this_length-2;
        sample_rate:=this_rate;
        handle.voice_info:=(voice_to_continue=>true,
                            sample_rate=>sample_rate,
                            packing=>this_pack,
                            remaining_length=>blklen);
        get_sound;
      when voice_continuation =>
        if not handle.voice_info.voice_to_continue then
          raise data_error;
        end if;
        handle.voice_info.remaining_length:=this_length;
        get_sound;
      when silence =>
        if this_length /= 3 then
          raise data_error;
        end if;
        block:=(silence,0,(duration(this_2)+1.0)/this_rate);
      when marker =>
        if this_length /= 2 then
          raise data_error;
        end if;
        block:=(block_type=>marker,block_length=>0,mark=>markers(this_2));
      when text =>
        block_length:=block_lengths(this_length-1);
        block:=(text,block_length,text_string=>(others=>' '));
        if dos_io.read(handle.file_handle,block.text_string(1)'address,
                       dos_io.byte_counts(block_length))
            /= dos_io.byte_counts(block_length) then
          raise data_error;
        end if;
        if dos_io.read(handle.file_handle,null_byte'address,1) /= 1
        or else null_byte /= 0 then
          raise data_error;
        end if;
      when start_repeat =>
        if this_length /= 2 then
          raise data_error;
        end if;
        block:=(start_repeat,0,voc_data.repeat_counts(this_2));
      when end_repeat =>
        if this_length /= 0 then
          raise data_error;
        end if;
        block:=(end_repeat,0);
    end case;
  end Read;

  procedure Create(Name   : in     String;
                   Handle : in out Handles) is
    header:headers:=
      (File_Type_Description => (others => 16#1A#),
       Offset_Of_Data_Block  => headers_bytes,
       version_minor         => 10,
       version_major         => 1,
       id_code_minor         => 16#29#,
       id_code_major         => 16#11#
      );
    magic_name:constant string:="Creative Voice File";
  begin
    for i in magic_name'range loop
      header.file_type_description(i-magic_name'first
                                    +header.file_type_description'first)
        :=character'pos(magic_name(i));
    end loop;
    begin
      dos_io.create(name,handle.file_handle);
    exception
      when dos_io.name_error => raise name_error;
    end;
    handle.is_input:=false;
    if Dos_IO.write(Handle.File_Handle, Header'Address, Headers_Bytes)
       /= Headers_Bytes then
      Dos_IO.Close(Handle.File_Handle);
      raise disk_full;
    end if;
  end create;

  procedure write_block_header(Handle     : in out Handles;
                               block_type : in     block_types;
                               blklen     : in     blklens) is
    block_header:block_headers:=(block_type,blklen);
  begin
    if Dos_IO.write(Handle.File_Handle,block_header'Address,
                    block_header_length) /= block_header_length then
      raise disk_full;
    end if;
  end write_block_header;

  procedure Write_sound(Handle  : in out Handles;
                        block   : in     VOC_data.blocks) is
    type infos is record
      sr     : one_byte_naturals;
      pack   : pack_types;
    end record;
    info:infos:=(one_byte_naturals(256-1000000/long_integer(block.sample_rate)),
                 block.packing);
    sound_length:constant dos_io.byte_counts
      :=dos_io.byte_counts(block.block_length);
  begin
    if handle.is_input then
      raise status_error;
    end if;
    if block.block_type /= voice_data then
      raise data_error;
    end if;
    write_block_header(Handle,voice_data,blklens(block.block_length+2));
    if dos_io.write(Handle.File_Handle,info'address,2) /= 2 then
      raise disk_full;
    end if;
    if dos_io.write(Handle.File_Handle,block.data(1)'address,sound_length)
       /= sound_length then
      raise disk_full;
    end if;
  end write_sound;

  procedure Write_silence(Handle      : in out Handles;
                          interval    : in duration;
                          sample_rate : in VOC_data.sample_rates:=8000) is
    type infos is record
      period : two_byte_naturals;
      sr     : one_byte_naturals;
    end record;
    period:two_byte_naturals:=two_byte_naturals(sample_rate*interval);
    info:infos;
    info_length:constant dos_io.byte_counts:=dos_io.byte_counts(info'size/8);
  begin
    if handle.is_input then
      raise status_error;
    end if;
    if period < 1 then return;end if;
    info:=(period-1,
           one_byte_naturals(256-1000000/long_integer(sample_rate)));
    write_block_header(handle,silence,3);
    if Dos_IO.write(Handle.File_Handle,info'Address,info_length)
       /= info_length then
      raise disk_full;
    end if;
  end write_silence;

  procedure Write_marker(Handle  : in out Handles;
                         mark    : in     VOC_data.markers) is
    m_length:constant dos_io.byte_counts:=dos_io.byte_counts(markers'size/8);
  begin
    if handle.is_input then
      raise status_error;
    end if;
    write_block_header(handle,marker,2);
    if Dos_IO.write(Handle.File_Handle,mark'Address,m_length) /= m_length then
      raise disk_full;
    end if;
  end write_marker;

  procedure Write_text(Handle  : in out Handles;
                       text    : in     string) is
    text_length:constant dos_io.byte_counts:=dos_io.byte_counts(text'length);
    null_byte:one_byte_naturals:=0;
  begin
    if handle.is_input then
      raise status_error;
    end if;
    write_block_header(handle,voc_data.text,text'length+1);
    if Dos_IO.write(Handle.File_Handle,text(text'first)'Address,text_length)
       /= text_length then
      raise disk_full;
    end if;
    if Dos_IO.write(Handle.File_Handle,null_byte'Address,1) /= 1 then
      raise disk_full;
    end if;
  end write_text;

  procedure Write_repeat(Handle  : in out Handles;
                         count   : in     VOC_data.repeat_counts) is
    r_length:constant dos_io.byte_counts:=dos_io.byte_counts(repeat_counts'size/8);
  begin
    if handle.is_input then
      raise status_error;
    end if;
    write_block_header(handle,start_repeat,2);
    if Dos_IO.write(Handle.File_Handle,count'Address,r_length) /= r_length then
      raise disk_full;
    end if;
  end write_repeat;

  procedure Write_end_repeat(Handle  : in out Handles) is
  begin
    if handle.is_input then
      raise status_error;
    end if;
    write_block_header(handle,end_repeat,0);
  end write_end_repeat;

  procedure Close(Handle  : in out Handles) is
    fini:block_types:=terminator;
    fini_length:constant dos_io.byte_counts:=dos_io.byte_counts(fini'size/8);
  begin
    if not handle.is_input then
      if Dos_IO.write(Handle.File_Handle,fini'Address,fini_length)
         /= fini_length then
        raise disk_full;
      end if;
    end if;
    Dos_IO.Close(Handle.File_Handle);
  end Close;

end VOC_IO;