PDL-IO-Dicom-2.098/0000755000175000017500000000000014736677226013463 5ustar osboxesosboxesPDL-IO-Dicom-2.098/Dicom.pm0000644000175000017500000003004114736675077015054 0ustar osboxesosboxes=pod =head1 NAME PDL::IO::Dicom - a module for reading DICOM images. =head1 DESCRIPTION The PDL::IO::Dicom module enables reading 16-bit gray level Dicom images into PDL. As Dicom is an extremely complex format, this module can unfortunately not handle all different image types included in the DICOM standard. One common format that is currently not supported is the Papyrus format. =head1 USAGE use PDL; use PDL::IO::Dicom; $img = rdcm("image.dcm"); =head1 SEE ALSO L =head1 AUTHOR Copyright (C) Dov Grobgeld 2002. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::IO::Dicom; use strict; use warnings; use PDL; use PDL::Core; use PDL::IO::Misc; use Exporter; our @ISA = qw( Exporter ); our @EXPORT = qw( rdcm ); our $VERSION = '2.098'; my $debug = 0; my %element_table = ( "0002,0000" => ["Group length","UL"], "0002,0001" => ["File Meta Information Version","OB"], "0002,0002" => ["Media Storage SOP Class UID","UI"], "0002,0003" => ["Media Storage SOP Instance UID","UI"], "0002,0010" => ["Transfer Syntax UID","UI"], "0002,0012" => ["Implementation Class UID","UI"], "0002,0013" => ["Implementation Version Name","SH"], "0002,0016" => ["Source Application Entity Title","AE"], "0008,0000" => ["Identifying Group Length", "UL"], "0008,0001" => ["Length to End"], "0008,0005" => ["Specific Character Set","CS"], "0008,0008" => ["Image Type","CS"], "0008,0010" => ["Recognition Code"], "0008,0012" => ["Instance Creation Date"], "0008,0013" => ["Instance Creation Time"], "0008,0014" => ["Instance Creator UID"], "0008,0016" => ["SOP Class UID","UI"], "0008,0018" => ["SOP Instance UID","UI"], "0008,0020" => ["Study Date","DA"], "0008,0021" => ["Series date","DA"], "0008,0022" => ["Acquisition Date","DA"], "0008,0023" => ["Image Date","DA"], "0008,0030" => ["Study Time","TM"], "0008,0031" => ["Series Time","TM"], "0008,0032" => ["Acquisition Time","TM"], "0008,0033" => ["Image Time","TM"], "0008,103e" => ["Series Description"], "0008,1030" => ["Study Description"], "0008,0050" => ["Accession Number","SH"], "0008,0060" => ["Modality","CS"], "0008,0070" => ["Manufacturer","LO"], "0008,0080" => ["Institution Name","LO"], "0008,0090" => ["Referring Physician's Name","PN"], "0008,1010" => ["Station Name","SH"], "0008,1030" => ["Study Description","LO"], "0008,103e" => ["Series Description","LO"], "0008,1060" => ["Name of Physician(s)","PN"], "0008,1090" => ["Manufacturers Model Name",], "0010,0000" => ["Patient Information Group"], "0010,0010" => ["Patient Name","PN"], "0010,0020" => ["Patient ID"], "0010,0030" => ["Patient Birth Date"], "0010,0040" => ["Patient's Sex"], "0010,1010" => ["Patient Age"], "0010,1030" => ["Patient Weight"], "0018,0000" => ["Acquisition Gnformation Group"], "0018,0010" => ["Contrast/Bolus Agent"], "0018,0020" => ["Scanning Sequence"], "0018,0022" => ["Scan Options"], "0018,0050" => ["Slice thickness"], "0018,1050" => ["Spatial Resolution", "lO"], "0008,1060" => ["Name of Physician(s) Reading Study"], "0008,1070" => ["Operator's Name"], "0018,0080" => ["Repetition Time"], "0018,0081" => ["Echo Time"], "0018,0082" => ["Inversion Time"], "0018,0083" => ["Number of Averages"], "0018,0084" => ["Imaging Frequency"], "0018,0085" => ["Imaged Nucleus"], "0018,0086" => ["Echo Number(s)"], "0018,0087" => ["Magnetic Field Strength"], "0018,0088" => ["Spacing Between Slices"], "0018,0089" => ["Number of Phase Encoding Steps"], "0018,0090" => ["Data Collection Diameter"], "0018,0091" => ["Echo Train Length"], "0018,0093" => ["Percent Sampling"], "0018,0094" => ["Percent Phase Field of View"], "0018,0095" => ["Pixel Bandwidth"], "0018,1088" => ["Heart Rate","US"], "0018,1090" => ["Cardiac Number of Images","US"], "0018,1094" => ["Trigger Window","US"], "0018,1100" => ["Reconstruction Diameter"], "0018,1314" => ["Flip Angle"], "0018,1315" => ["Variable Flip Angle Flag"], "0018,1316" => ["SAR"], "0020,0000" => ["Relationship information group"], "0020,000d" => ["Study Instance UID"], "0020,000e" => ["Series Instance UID"], "0020,0010" => ["Study ID"], "0020,0011" => ["Series Number"], "0020,0012" => ["Acquisition Number"], "0020,0013" => ["Image Number"], "0020,0014" => ["Isotope Number"], "0020,0015" => ["Phase Number"], "0020,0016" => ["Interval Number"], "0020,0017" => ["Time Slot Number"], "0020,0018" => ["Angle Number"], "0020,0020" => ["Patient Orientation"], "0020,0022" => ["Overlay Number"], "0020,0024" => ["Curve Number"], "0020,0026" => ["LUT Number"], "0020,0030" => ["Image Position"], "0020,0032" => ["Image Position (Patient)"], "0020,0035" => ["Image Orientation"], "0020,0037" => ["Image Orientation (Patient)"], "0020,0050" => ["Location"], "0020,0052" => ["Frame of Reference UID"], "0020,0060" => ["Laterality"], "0020,1002" => ["Images in acqusition"], "0020,1040" => ["Position Reference Indicator"], "0020,1041" => ["Slice Location"], "0028,0000" => ["Relationship information group"], "0028,0002" => ["Samples per Pixel"], "0028,0004" => ["Photometric Interpretation"], "0028,0005" => ["Image Dimensions"], "0028,0010" => ["Rows", "US"], "0028,0011" => ["Columns", "US"], "0028,0030" => ["Pixel Spacing"], "0028,0100" => ["Bits Allocated","US"], "0028,0101" => ["Bits Stored", "US"], "0028,0102" => ["High Bit","US"], "0028,0103" => ["Pixel Representation","US"], "0028,1052" => ["Rescale Intercept"], "0028,1053" => ["Rescale Slope"], "0033,1002" => ["IMGF"], "7fe0,0000" => ["Pixel Data Information Group", "UL"], "7fe0,0010" => ["Pixel Data","OW"] ); =head1 FUNCTIONS =head2 rdcm =for ref Read a dicom image. =for usage $dcm = rdcm("filename") =cut sub rdcm { my $file = shift; my $options = shift; my $do_print_info = 0; my (%info, %bin); my $do_raw = 0; # Only for debugging my ($rescale_intercept, $rescale_slope) = (0, 1); my $do_explicit = 0; my $do_guess_endian = 1; # options if ($options) { if (defined $options->{do_print_info}) { $do_print_info = $options->{do_print_info}; } } open(IN, $file) || die "Failed opening image $file!\n"; binmode IN; # read the whole image my $header; read(IN, $header, -s $file); # File preamble - a fixed 128 byte field my $hpos = 0x80; # Next four bytes should be DICM if (substr($header, $hpos, 4) ne 'DICM') { die "This is not a DICM file!\n"; } $hpos+= 4; # Precheck if the first entry has explicit vr. Unfortunately this # is not enough to determine if the file always has explicit value # representation. if (substr($header, $hpos+4, 2)=~ /[A-Z]{2}/) { $do_explicit++; } while($hpos < length($header)) { my $is_binary = 0; my $groupword = unpack("v", substr($header, $hpos, 2)); $hpos+=2; my $elementword = unpack("v", substr($header, $hpos, 2)); $hpos+=2; my $value_rep = substr($header, $hpos, 2); my $key = sprintf("%04x,%04x", $groupword, $elementword); my ($lookup) = $element_table{$key}; my $override_vr = 0; # Check for explicit value representation. There must be a different # way to figure this out, but I still haven't figured out how! if ($value_rep =~ /[A-Z][A-Z]/) { $hpos+=2; } else { $override_vr++; $value_rep = $lookup->[1] || "UN"; } my $elementlength; if (substr($header, $hpos, 4) eq "IMGF") { die "No support for IMGF files at the moment!\n"; } # The following calculation agrees with dicom3tools if ($override_vr) { $elementlength = unpack("V", substr($header, $hpos, 4)); $hpos+= 4; } elsif (grep($value_rep eq $_, qw(OB OW SQ UN))) { # Long length $is_binary = 1; $hpos+= 2; # Always zero $elementlength = unpack("V", substr($header, $hpos, 4)); $hpos+= 4; } else { # Short length $elementlength = unpack("v", substr($header, $hpos, 2)); $hpos+= 2; } my ($descr) = ""; my $contents = substr($header, $hpos, $elementlength) . ""; ($descr) = @$lookup if $lookup; # recode contents if ($value_rep eq "UL") { $contents = unpack("V", $contents); } elsif ($value_rep eq "US") { $contents = unpack("v", $contents); } elsif ($value_rep eq "TM") { $contents = clean_time($contents); } elsif ($value_rep eq "DA") { $contents = clean_date($contents); } elsif (!$is_binary) { $contents=~ s/\s+$//; } # store the contents if ($key eq "7fe0,0010") { # Pixel data $bin{$descr} = $contents; } else { $info{$descr} = $contents if $descr; } if ($do_print_info) { $contents = "" unless $contents; $contents = "<>" if $is_binary; $contents=~ tr/\0-\037\200-\377//d; $contents= substr($contents, 0, 40) unless $do_raw; $contents=~ s/[\0-\037\200]/?/g; $value_rep=~ s/[\0-\037]/?/g; printf STDERR "%04x> %04x,%04x (%04x,$value_rep) %-30s : %s\n", $hpos, $groupword, $elementword, $elementlength, $descr, $contents; } $hpos+= $elementlength; } my($width, $height) = ($info{Columns}, $info{Rows}); my($bs) = $info{"Bits Allocated"}/8; my $img = $bin{"Pixel Data"}; # The following logics works on Intel endian my $do_toggle_endian = $info{"Pixel Representation"}; $rescale_intercept = $info{"Rescale Intercept"} if defined $info{"Rescale Intercept"}; $rescale_slope = $info{"Rescale Slope"} if defined $info{"Rescale Slope"}; my $pdl; # Create a pdl from the raw data if ($bs == 2) { $pdl = zeroes(ushort, $width,$height); my $hdr = $pdl->gethdr; $pdl->make_physical(); # Store the pixel data ${$pdl->get_dataref()} = $img; # Guess endian if ($do_guess_endian) { # Compare spread of high byte with low byte my $high_byte = ($pdl>>8)->byte; my $low_byte = ($pdl & 0xff)->byte; my $max_high = $high_byte->max; my $max_low = $low_byte->max; # print STDERR "max_high max-low = $max_high $max_low\n"; # The following might need to be adjusted on different # architectures. $do_toggle_endian = $max_high > $max_low; } # Endian swap if ($do_toggle_endian) { bswap2($pdl); } # Rescale and convert to double if ($rescale_intercept != 0 || $rescale_slope != 1) { print STDERR "scaling with $rescale_slope and $rescale_intercept\n"; $pdl = 1.0*($pdl * $rescale_slope) + $rescale_intercept; } } else { die "Sorry! PDL::IO::Dicom currently only supported DICOM with bs=2. bs = $bs\n"; } # Store the info in the pdl header $pdl->sethdr(\%info); return $pdl; } sub clean_time { my $time = shift; my ($hour, $min, $sec, $sec_frac); if ($time=~ /(\d+):(\d+):(\d+)\.?(\d*)/) { ($hour,$min,$sec,$sec_frac) = ($1,$2,$3,$4); } elsif ($time=~ /(\d\d)(\d\d)(\d\d)\.?(\d+)/) { ($hour,$min,$sec,$sec_frac) = ($1,$2,$3,$4); } if (defined $hour) { $time = sprintf("%02d:%02d:%02d", $hour, $min, $sec); $time .= ".$sec_frac" if $sec_frac; } return $time; } sub clean_date { my $date = shift; $date=~ s/(\d\d\d\d)(\d\d)(\d\d)/$1-$2-$3/; return $date; } =head1 AUTHOR Copyright (C) Dov Grobgeld 1997. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut 1; PDL-IO-Dicom-2.098/META.json0000644000175000017500000000251014736677226015102 0ustar osboxesosboxes{ "abstract" : "unknown", "author" : [ "PerlDL Developers " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "PDL-IO-Dicom", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0", "PDL" : "2.094" } }, "runtime" : { "requires" : { "PDL" : "2.094" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/PDLPorters/PDL-IO-Dicom/issues" }, "homepage" : "http://pdl.perl.org/", "repository" : { "type" : "git", "url" : "git://github.com/PDLPorters/PDL-IO-Dicom.git", "web" : "https://github.com/PDLPorters/PDL-IO-Dicom" }, "x_IRC" : "irc://irc.perl.org/#pdl" }, "version" : "2.098", "x_serialization_backend" : "JSON::PP version 4.04" } PDL-IO-Dicom-2.098/META.yml0000644000175000017500000000137514736677226014742 0ustar osboxesosboxes--- abstract: unknown author: - 'PerlDL Developers ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' PDL: '2.094' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PDL-IO-Dicom no_index: directory: - t - inc requires: PDL: '2.094' resources: IRC: irc://irc.perl.org/#pdl bugtracker: https://github.com/PDLPorters/PDL-IO-Dicom/issues homepage: http://pdl.perl.org/ repository: git://github.com/PDLPorters/PDL-IO-Dicom.git version: '2.098' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' PDL-IO-Dicom-2.098/Changes0000644000175000017500000000021614736675746014762 0ustar osboxesosboxes2.098 2025-01-06 - add licence information 2.097 2024-12-09 - install pdldoc, add repo metadata 2.096 2024-12-04 - split out from PDL 2.095 PDL-IO-Dicom-2.098/MANIFEST0000644000175000017500000000034314736677226014614 0ustar osboxesosboxesChanges Dicom.pm Makefile.PL MANIFEST This list of files META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) PDL-IO-Dicom-2.098/Makefile.PL0000644000175000017500000000203114736671344015424 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; use PDL::Core::Dev; my $package_name = "PDL::IO::Dicom"; (my $repo = $package_name) =~ s#::#-#g; $repo = "PDLPorters/$repo"; WriteMakefile( NAME => $package_name, VERSION_FROM => 'Dicom.pm', AUTHOR => 'PerlDL Developers ', LICENSE=> "perl", CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => 0, 'PDL' => '2.094', }, PREREQ_PM => { 'PDL' => '2.094', }, META_MERGE => { "meta-spec" => { version => 2 }, resources => { homepage => 'http://pdl.perl.org/', bugtracker => {web=>"https://github.com/$repo/issues"}, repository => { url => "git://github.com/$repo.git", type => 'git', web => "https://github.com/$repo", }, x_IRC => 'irc://irc.perl.org/#pdl', }, }, ); sub MY::postamble { my $oneliner = PDL::Core::Dev::_oneliner(qq{exit if \$ENV{DESTDIR}; use PDL::Doc; eval { PDL::Doc::add_module(shift); }}); qq|\ninstall :: pure_install\n\t$oneliner \$(NAME)\n|; }