Commit 197cac31 authored by Gary Allen Vollink's avatar Gary Allen Vollink
Browse files

Files split

parent ed4d0c56
This diff is collapsed.
This diff is collapsed.
#!/usr/bin/perl
##############################################################################
# Read musicdb-dump.pl
# Output datablocks.c
##
use strict;
use warnings qw{ all };
use lib '.';
use Offsets;
my %UniqueString;
my @KeyOrder;
my %UniqueKey;
my @HFiles = (qw(datablocks.h db_lang.h));
my @CFiles = (qw(datablocks.c db_lang_en.c));
my @PFiles = (qw(Offset_lang_en.pm));
use constant C_STYLE => (99);
use constant PL_STYLE => (112);
use constant PM_STYLE => (109);
MAIN:
{
write_datablocks();
write_lang();
print "Wrote PM: @PFiles\n";
print "Wrote C: @HFiles @CFiles\n";
}
sub write_lang
{
my $fhc = undef;
my $fhh = undef;
my $fhp = undef;
open ( $fhp, '>', $PFiles[0] ) or die( $! );
open ( $fhc, '>', $CFiles[1] ) or die( $! );
open ( $fhh, '>', $HFiles[1] ) or die( $! );
print {$fhp} top_lang_pm();
print {$fhc} top_lang_c();
print {$fhh} top_lang_h();
print {$fhc} "char *\ndb_lang_en(u_int64_t ask)\n{\n";
print {$fhc} " switch( ask ) {\n";
my $cx = 0x001A0000;
foreach my $key ( @KeyOrder ) {
my $str = $UniqueKey{$key};
if ( 't' eq $UniqueString{$str}->{'type'} ) {
my $typid = $UniqueString{$str}->{'key'};
printf {$fhp} qq{use constant %-34s => (0x%08X) ;\n}, $typid, $cx;
printf {$fhh} qq{#define %-34s (0x%08X)\n}, $typid, $cx;
$cx++;
printf {$fhc} qq{ case ( %s ):\n}, $typid;
printf {$fhc} qq{ return "%s";\n}, $str;
printf {$fhc} qq{ break;\n};
}
}
$cx = 0x001B0000;
foreach my $key ( @KeyOrder ) {
my $str = $UniqueKey{$key};
if ( 'l' eq $UniqueString{$str}->{'type'} ) {
my $typid = $UniqueString{$str}->{'key'};
printf {$fhp} qq{use constant %-34s => (0x%08X) ;\n}, $typid, $cx;
printf {$fhh} qq{#define %-34s (0x%08X)\n}, $typid, $cx;
$cx++;
printf {$fhc} qq{ case ( %s ):\n}, $typid;
printf {$fhc} qq{ return "%s";\n}, $str;
printf {$fhc} qq{ break;\n};
}
}
print {$fhp} qq{\nmy %Offset_Lang_En;\n};
print {$fhp} qq{my %Offset_Lang_Rev;\n\n};
foreach my $key ( @KeyOrder ) {
printf {$fhp} q($Offset_Lang_En{'%s'} = "%s";%s),
$key, $UniqueKey{$key}, qq{\n};
}
print {$fhp} qq{\n};
foreach my $key ( @KeyOrder ) {
printf {$fhp} q($Offset_Lang_Rev{'%s'} = "%s";%s),
$UniqueKey{$key}, $key, qq{\n};
}
print {$fhc} qq{ default:\n};
print {$fhc} qq{ return "";\n};
print {$fhc} qq{ break;\n};
print {$fhc} " }\n";
print {$fhc} "}\n";
print {$fhc} bottom_lang_c();
print {$fhh} bottom_lang_h();
print {$fhp} bottom_lang_pm();
close( $fhp );
close( $fhc );
close( $fhh );
}
sub mk_key
{
my $str = shift;
my $typid = "L_" . uc($str);
if ( $str =~ m/iAma/ ) {
$typid =~ s/IAMA/I_A_MA/g;
}
$typid =~ s/[,\-\+\/\?\.\s]/_/g;
$typid =~ s/[\)\(\[\]]//g;
my $base = $typid;
my $cx = 0;
while ( exists( $UniqueKey{$typid} ) ) {
$typid = $base . $cx++;
}
$UniqueKey{$typid} = $str;
push @KeyOrder, ( $typid );
return $typid;
}
sub write_datablocks
{
my $fhc = undef;
my $fhh = undef;
open ( $fhc, '>', $CFiles[0] ) or die( $! );
open ( $fhh, '>', $HFiles[0] ) or die( $! );
print {$fhc} top_out_c();
print {$fhh} top_out_h();
envelope_out($fhc, $fhh);
map_out($fhc, $fhh);
print {$fhc} bottom_out_c();
print {$fhh} bottom_out_h();
close( $fhc );
close( $fhh );
}
sub map_out
{
my $fhc = shift;
my $fhh = shift;
print {$fhc} "\n/* Maps musicdb */\n\n";
print {$fhh} "\n/* Maps musicdb */\n\n";
foreach my $m ( qw[
hsma hfma plma lama iama lAma
iAma ltma itma lPma lpma boma
] ) {
print {$fhh} qq(extern struct block $m;\n);
onemap_out($fhc, $m);
}
my $map = Offsets::section_map();
foreach my $m ( sort keys %$map ) {
if ( $m =~ m/^boma_\w+$/ ) {
print {$fhh} qq(extern struct block $m;\n);
onemap_out( $fhc, $m );
}
}
print {$fhc} "\n/* Maps musicdb (first found in Application.musicdb) */\n\n";
print {$fhh} "\n/* Maps musicdb (first found in Application.musicdb) */\n\n";
foreach my $m ( qw[
hqma iqma ssma
] ) {
print {$fhh} qq(extern struct block $m;\n);
onemap_out($fhc, $m);
}
print {$fhc} "\n/* Maps itl iTunes */\n\n";
print {$fhh} "\n/* Maps itl iTunes */\n\n";
foreach my $m ( qw[
msdh mfdh mhgh mlah miah mlih
miih mlth mith mlqh miqh stsh
mlph miph mtph mlsh msph mlrh
mprh mhdh mhoh
] ) {
print {$fhh} qq(extern struct block $m;\n);
onemap_out($fhc, $m);
}
foreach my $m ( sort keys %$map ) {
if ( $m =~ m/^mhoh_\w+$/ ) {
print {$fhh} qq(extern struct block $m;\n);
onemap_out( $fhc, $m );
}
}
print {$fhh} qq(\nextern struct block *LocMap[];\n);
print {$fhc} qq(\nstruct block *LocMap[] = {\n); # }
my $needcomma = 0;
my $counttypes = 0;
foreach my $m ( sort keys %$map ) {
#if ( ( $m !~ m/^boma_/ )
# && ( $m !~ m/^mhoh_/ ) )
#{
if ( $needcomma ) {
print {$fhc} qq(,\n);
} else {
$needcomma = 1;
}
print {$fhc} qq( &$m);
$counttypes++;
#}
}
# {
print {$fhc} qq(\n};\n);
print {$fhh} qq(extern u_int16_t LocMapCount;\n);
print {$fhc} qq(u_int16_t LocMapCount = ${counttypes};\n);
print {$fhc} qq(\n);
}
sub onemap_out
{
my $fh = shift;
my $one = shift;
my $map = Offsets::section_map();
printf {$fh} qq(struct block $one = {\n); # }
printf {$fh} qq( "%s",%s/* Type */\n),
$one, (" " x ( 52 - length($one) ) );
if ( ( exists $map->{$one}->{'subtitle'} )
&& ( length $map->{$one}->{'subtitle'} ) )
{
my $subtitle = $map->{$one}->{'subtitle'};
my $usk;
if ( exists $UniqueString{$subtitle} ) {
$usk = $UniqueString{$subtitle}->{'key'};
$UniqueString{$subtitle}->{'count'}++;
} else {
$usk = mk_key($subtitle);
$UniqueString{$subtitle} = {
count => 1,
type => 't',
key => $usk,
};
}
printf {$fh} qq{ %s,%s/* title */\n},
$usk, ( " " x ( 54 - length($usk) ) );
delete $map->{$one}->{'subtitle'};
} else {
printf {$fh} qq{ L_EMPTY,%s/* title */\n}, " " x 47;
}
print {$fh} offsets_out($fh, $map->{$one});
# {
print {$fh} qq(};\n);
print {$fh} qq(\n);
}
sub envelope_out
{
my $fhc = shift;
my $fhh = shift;
print {$fhh} qq(extern struct block envelope;\n); # }
print {$fhc} qq(struct block envelope = {\n); # }
print {$fhc} qq( "Envelope",\n);
print {$fhc} qq( L_ENVELOPE,\n);
print {$fhc} offsets_out($fhc, $Offsets::envelope);
# {
print {$fhc} qq(};\n);
print {$fhc} qq(\n);
print {$fhh} qq(extern struct block hfma_envelope;\n); # }
print {$fhc} qq(struct block hfma_envelope = {\n); # }
print {$fhc} qq( "hfma e",\n);
print {$fhc} qq( L_MDB_ENVELOPE,\n);
print {$fhc} offsets_out($fhc, $Offsets::hfma_envelope);
# {
print {$fhc} qq(};\n);
print {$fhc} qq(\n);
print {$fhh} qq(extern struct block mfdh_envelope;\n); # }
print {$fhc} qq(struct block mfdh_envelope = {\n); # }
print {$fhc} qq( "mfdh e",\n);
print {$fhc} qq( L_ITL_ENVELOPE,\n);
print {$fhc} offsets_out($fhc, $Offsets::mfdh_envelope);
# {
print {$fhc} qq(};\n);
print {$fhc} qq(\n);
}
sub offsets_out
{
my $fh = shift;
my $set = shift;
my $cx = 0;
my $out = q{};
foreach my $key ( sort { $a <=> $b } keys %{$set} ) {
if ( $key =~ m/^\d+$/ ) {
if ( 'ARRAY' eq ref($set->{$key}) ) {
if ( $cx ) {
$out .= sprintf( ",\n" );
} else {
$out .= sprintf( " {\n" ); # }
}
$out .= sprintf( "%s{\n", ( " " x 8 ) ); # }
$cx++;
my @offset = @{$set->{$key}};
if ( 2 == scalar(@offset) ) {
unshift @offset, 'integer';
}
my $usk;
if ( exists $UniqueString{$offset[2]} ) {
$usk = $UniqueString{$offset[2]}->{'key'};
$UniqueString{$offset[2]}->{'count'}++;
} else {
$usk = mk_key($offset[2]);
$UniqueString{$offset[2]} = {
count => 1,
type => 'l',
key => $usk,
};
}
$out .= sprintf( "%s%s,\n", ( " " x 12 ), $key);
if ( 'signed' eq $offset[0] ) {
$out .= sprintf( "%ssignedint,\n", ( " " x 12 ));
} else {
$out .= sprintf( "%s%s,\n", ( " " x 12 ), $offset[0]);
}
$out .= sprintf( "%s%s,\n", ( " " x 12 ), $offset[1]);
$out .= sprintf( qq{%s%s\n}, ( " " x 12 ), $usk);
# {
$out .= sprintf( "%s}", ( " " x 8 ) );
}
}
}
$out .= sprintf( "\n" );
my $final = sprintf( "%s%s,%s/* Offset Count */\n",
( " " x 4 ), $cx, ( " " x 53 ) );
$final .= $out;
# {
$final .= sprintf( "%s}\n", ( " " x 4 ) );
return $final;
}
sub top_lang_h
{
my $out = q{};
$out .= file_top( C_STYLE, 'libmusicdb/datablocks language header' );
$out .= comment_continue( C_STYLE, 'See datablocks.c.');
$out .= generated_by( C_STYLE );
$out .= comment_end( C_STYLE );
$out .= sprintf( "#ifndef MUSICDB_DB_LANG_H\n" );
$out .= sprintf( "#define MUSICDB_DB_LANG_H\n" );
$out .= sprintf( qq{#include "musicdb.h"\n\n} );
$out .= sprintf( "\n" );
return $out;
}
sub top_out_h
{
my $out = q{};
$out .= file_top( C_STYLE, 'libmusicdb/datablocks header' );
$out .= comment_continue( C_STYLE, 'See datablocks.c.');
$out .= generated_by( C_STYLE );
$out .= comment_end( C_STYLE );
$out .= sprintf( "#ifndef MUSICDB_DATABLOCKS_H\n" );
$out .= sprintf( "#define MUSICDB_DATABLOCKS_H\n" );
$out .= sprintf( "#ifndef MUSICDB_DATABLOCKS_C\n" );
$out .= sprintf( qq{#include "musicdb.h"\n\n} );
$out .= sprintf( "\n" );
return $out;
}
sub bottom_lang_h
{
my $out = q{};
$out .= sprintf( "\n#endif\n" );
$out .= comment_one( C_STYLE, 'EOF db_lang.h' );
return $out;
}
sub bottom_out_h
{
my $out = q{};
$out .= sprintf( "\n#endif\n" );
$out .= sprintf( "#endif\n" );
$out .= comment_one( C_STYLE, 'EOF datablocks.h' );
return $out;
}
sub set_style
{
my $style = shift;
my %style;
if ( C_STYLE == $style )
{
$style{'cs'} = "/*";
$style{'cf'} = "*";
$style{'ce'} = "*/";
$style{'co'} = 1;
} elsif (( PL_STYLE == $style) || ( PM_STYLE == $style )) {
$style{'cs'} = "#";
$style{'cf'} = "#";
$style{'ce'} = "";
$style{'co'} = 0;
}
return \%style;
}
sub comment_one
{
my $style = shift;
my $words = shift;
my $st = set_style( $style );
my $offset = shift || 0;
my $out = q{};
$out .= sprintf( "%s%s %s %s\n",
( $offset? " " x $offset: "" ),
$st->{'cs'},
$words,
($st->{'ce'}? $st->{'ce'}: "") );
return $out;
}
sub comment_start
{
my $style = shift;
my $words = shift;
my $st = set_style( $style );
my $offset = shift || 0;
my $out = q{};
$out .= sprintf( "%s%s\n",
( $offset? " " x $offset: "" ),
$st->{'cs'} );
if ( length( $words ) ) {
$out .= comment_continue($style, $words, $offset);
}
return $out;
}
sub comment_continue
{
my $style = shift;
my $words = shift;
my $st = set_style( $style );
my $offset = shift || $st->{'co'};
my $out = q{};
if ( 0 == length( $words ) ) {
$out .= sprintf( "%s%s\n",
( $offset? " " x $offset: "" ),
$st->{'cf'} );
} elsif ( ( 75 - $offset ) > length( $words ) ) {
$out .= sprintf( "%s%s %s\n",
( $offset? " " x $offset: "" ),
$st->{'cf'},
$words
);
$words = "";
} else {
my @token = split( /\s+/, $words );
my $next = q{};
BUILD: while ( scalar( @token ) ) {
if (( 75 - $offset ) < ( length( $next ) + length($token[0]) )) {
if ( length( $next ) ) {
$out .= sprintf( "%s%s %s\n",
( $offset? " " x $offset: "" ),
$st->{'cf'},
$next
);
$next = q{};
next;
} else {
$out .= sprintf( "%s%s %s\n",
( $offset? " " x $offset: "" ),
$st->{'cf'},
shift @token
);
next;
}
}
my $next .= sprintf( " %s", shift @token );
}
if ( length( $next ) ) {
$out .= sprintf( "%s%s %s\n",
( $offset? " " x $offset: "" ),
$st->{'cf'},
$next
);
$next = q{};
}
}
return $out;
}
sub comment_end
{
my $style = shift;
my $st = set_style( $style );
my $offset = shift || $st->{'co'};
my $out = q{};
if ( length( $st->{'ce'} ) ) {
$out .= sprintf( "%s%s\n",
( $offset? " " x $offset: "" ),
$st->{'ce'} );
}
return $out;
}
sub file_top
{
my $style = shift;
my $label = shift;
my $st = set_style( $style );
my $out = q{};
if ( PL_STYLE == $style ) {
$out .= "#!/usr/bin/env perl\n";
}
$out .= sprintf( "%s%s\n",
$st->{'cs'},
( $st->{'cf'} x ( 77 - length($st->{'cs'}) ) ) );
$out .= sprintf( "%s%s %s\n",
( $st->{'co'}?" " x $st->{'co'}:"" ),
$st->{'cf'}, $label );
$out .= sprintf( "%s%s\n",
( $st->{'co'}?" " x $st->{'co'}:"" ),
$st->{'cf'} );
return $out;
}
sub generated_by
{
my $style = shift;
my $st = set_style($style);
my $offset = shift || $st->{'co'};
my $out = q{};
my @tm = gmtime( time() );
my $dstr = sprintf( "%04d-%02d-%02dT%02d:%02d:%02dZ",
$tm[5] + 1900, $tm[4] + 1,
$tm[3], $tm[2], $tm[1], $tm[0] );
$out .= comment_continue( $style, '', $offset );
$out .= comment_continue( $style,
'File generated by write_datablocks.pl at '. $dstr, $offset );
$out .= comment_continue( $style,
'Generator written by Gary Allen Vollink, 2021', $offset );
return $out;
}
sub top_out_c
{
my $out = q{};
$out .= file_top( C_STYLE, 'libmusicdb/datablocks' );
$out .= comment_continue( C_STYLE,
'Datapoints described from' );
$out .= comment_continue( C_STYLE,
' https://www.home.vollink.com/gary/playlister/musicdb.html' );
$out .= comment_continue( C_STYLE,
'and https://www.home.vollink.com/gary/playlister/libitunes.html' );
$out .= generated_by( C_STYLE );
$out .= comment_end( C_STYLE );
$out .= sprintf( "#define MUSICDB_DATABLOCKS_C\n" );
$out .= sprintf( qq{#include "musicdb.h"\n} );
$out .= sprintf( "\n" );
return $out;
}
sub bottom_out_c
{
return comment_one( C_STYLE, 'EOF datablocks.c' );
}
sub top_lang_c
{
my $out = q{};
$out .= file_top( C_STYLE, 'libmusicdb/datablocks languge en' );
$out .= comment_continue( C_STYLE,
'English strings that define datablock parts' );
$out .= generated_by( C_STYLE );
$out .= comment_end( C_STYLE );
$out .= sprintf( "#define MUSICDB_DB_LANG_EN_C\n" );
$out .= sprintf( qq{#include "musicdb.h"\n} );
$out .= sprintf( "\n" );
return $out;
}
sub bottom_lang_c
{
return comment_one( C_STYLE, 'EOF db_lang_en.c' );
}
sub top_lang_pm
{
my $out = q{};
$out .= file_top( PM_STYLE, 'Offset_lang_en.pm' );
$out .= comment_continue( PM_STYLE, 'For future use?' );
$out .= generated_by( PM_STYLE );
$out .= comment_end( PM_STYLE );
$out .= sprintf( "%s\n", '##' );
$out .= sprintf( "%s\n", 'package Offset_lang_en;' );
$out .= sprintf( "%s\n", 'use strict;' );
$out .= sprintf( "%s\n", 'use warnings qw(ALL);' );
$out .= sprintf( "\n" );
return $out;
}
sub bottom_lang_pm
{
my $out = q{};
$out .= sprintf( "\n" );
$out .= sprintf( "1;\n" );
$out .= sprintf( "\n" );
$out .= comment_one( PM_STYLE, 'EOF Offset_lang_en.pm' );
return $out;
}